ADDED attic/records-vs-vectors-vs-coops.scm
Index: attic/records-vs-vectors-vs-coops.scm
==================================================================
--- /dev/null
+++ attic/records-vs-vectors-vs-coops.scm
@@ -0,0 +1,110 @@
+;; 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 "vg.scm")
+
+;; (declare (uses vg))
+
+(use foof-loop defstruct coops)
+
+(defstruct obj type fill-color angle)
+
+(define (make-vg:obj)(make-vector 3))
+(define-inline (vg:obj-get-type vec) (vector-ref vec 0))
+(define-inline (vg:obj-get-fill-color vec) (vector-ref vec 1))
+(define-inline (vg:obj-get-angle vec) (vector-ref vec 2))
+(define-inline (vg:obj-set-type! vec val)(vector-set! vec 0 val))
+(define-inline (vg:obj-set-fill-color! vec val)(vector-set! vec 1 val))
+(define-inline (vg:obj-set-angle! vec val)(vector-set! vec 2 val))
+
+(use simple-exceptions)
+(define vgs:obj-exn (make-exception "wrong record type, expected vgs:obj." 'assert))
+(define (make-vgs:obj)(let ((v (make-vector 4)))(vector-set! v 0 'vgs:obj) v))
+(define-inline (vgs:obj-type vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 1)(raise (vgs:obj-exn 'vgs:obj-type 'xpr))))
+(define-inline (vgs:obj-fill-color vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 2)(raise (vgs:obj-exn 'vgs:obj-fill-color 'xpr))))
+(define-inline (vgs:obj-angle vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 3)(raise (vgs:obj-exn 'vgs:obj-angle 'xpr))))
+(define-inline (vgs:obj-type-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 1 val)(raise (vgs:obj-exn 'type))))
+(define-inline (vgs:obj-fill-color-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 2 val)(raise (vgs:obj-exn 'fill-color))))
+(define-inline (vgs:obj-angle-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 3 val)(raise (vgs:obj-exn 'angle))))
+
+(define-class ()
+ ((type)
+ (fill-color)
+ (angle)))
+
+
+;; first use raw vectors
+(print "Using vectors")
+(time
+ (loop ((for r (up-from 0 (to 255))))
+ (loop ((for g (up-from 0 (to 255))))
+ (loop ((for b (up-from 0 (to 255))))
+ (let ((obj (make-vg:obj)))
+ (vg:obj-set-type! obj 'abc)
+ (vg:obj-set-fill-color! obj "green")
+ (vg:obj-set-angle! obj 135)
+ (let ((a (vg:obj-get-type obj))
+ (b (vg:obj-get-fill-color obj))
+ (c (vg:obj-get-angle obj)))
+ obj))))))
+
+;; first use raw vectors with safe mode
+(print "Using vectors (safe mode)")
+(time
+ (loop ((for r (up-from 0 (to 255))))
+ (loop ((for g (up-from 0 (to 255))))
+ (loop ((for b (up-from 0 (to 255))))
+ (let ((obj (make-vgs:obj)))
+ ;; (badobj (make-vector 20)))
+ (vgs:obj-type-set! obj 'abc)
+ (vgs:obj-fill-color-set! obj "green")
+ (vgs:obj-angle-set! obj 135)
+ (let ((a (vgs:obj-type obj))
+ (b (vgs:obj-fill-color obj))
+ (c (vgs:obj-angle obj)))
+ obj))))))
+
+;; first use defstruct
+(print "Using defstruct")
+(time
+ (loop ((for r (up-from 0 (to 255))))
+ (loop ((for g (up-from 0 (to 255))))
+ (loop ((for b (up-from 0 (to 255))))
+ (let ((obj (make-obj)))
+ (obj-type-set! obj 'abc)
+ (obj-fill-color-set! obj "green")
+ (obj-angle-set! obj 135)
+ (let ((a (obj-type obj))
+ (b (obj-fill-color obj))
+ (c (obj-angle obj)))
+ obj))))))
+
+
+;; first use defstruct
+(print "Using coops")
+(time
+ (loop ((for r (up-from 0 (to 255))))
+ (loop ((for g (up-from 0 (to 255))))
+ (loop ((for b (up-from 0 (to 255))))
+ (let ((obj (make )))
+ (set! (slot-value obj 'type) 'abc)
+ (set! (slot-value obj 'fill-color) "green")
+ (set! (slot-value obj 'angle) 135)
+ (let ((a (slot-value obj 'type))
+ (b (slot-value obj 'fill-color))
+ (c (slot-value obj 'angle)))
+ obj))))))
Index: megamod.scm
==================================================================
--- megamod.scm
+++ megamod.scm
@@ -86,10 +86,11 @@
spiffy
spiffy-directory-listing
spiffy-request-vars
sql-de-lite
srfi-1
+ srfi-4
srfi-13
srfi-18
srfi-69
stack
stml2
@@ -157,10 +158,11 @@
(include "keys-inc.scm")
(include "launch-inc.scm")
(include "margs-inc.scm")
(include "mt-inc.scm")
(include "ods-inc.scm")
+(include "pgdb-inc.scm")
(include "process-inc.scm")
(include "rmt-inc.scm")
(include "runconfig-inc.scm")
(include "runs-inc.scm")
(include "server-inc.scm")
ADDED pgdb-inc.scm
Index: pgdb-inc.scm
==================================================================
--- /dev/null
+++ pgdb-inc.scm
@@ -0,0 +1,651 @@
+;;======================================================================
+;; 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 .
+
+;;======================================================================
+
+;; I don't know how to mix compilation units and modules, so no module here.
+;;
+;; (module pgdb
+;; (
+;; open-pgdb
+;; )
+;;
+;; (import scheme)
+;; (import data-structures)
+;; (import chicken)
+
+;; given a configdat lookup the connection info and open the db
+;;
+(define (pgdb:open configdat #!key (dbname #f)(dbispec #f))
+ (let ((pgconf (or dbispec
+ (args:get-arg "-pgsync")
+ (if configdat
+ (configf:lookup configdat "ext-sync" (or dbname "pgdb"))
+ #f)
+ )))
+ (if pgconf
+ (let* ((confdat (map (lambda (conf-item)
+ (let ((parts (string-split conf-item ":")))
+ (if (> (length parts) 1)
+ (let ((key (car parts))
+ (val (cadr parts)))
+ (cons (string->symbol key) val))
+ (begin
+ (print "ERROR: Bad config setting " conf-item ", should be key:val")
+ `(,(string->symbol (car parts)) . #f)))))
+ (string-split pgconf)))
+ (dbtype (string->symbol (or (alist-ref 'dbtype confdat) "pg"))))
+ (if (alist-ref 'dbtype confdat)
+ (dbi:open dbtype (alist-delete 'dbtype confdat))))
+ #f)))
+
+;;======================================================================
+;; A R E A S
+;;======================================================================
+
+(defstruct area id area-name area-path last-update)
+
+(define (pgdb:add-area dbh area-name area-path)
+ (dbi:exec dbh "INSERT INTO areas (area_name,area_path) VALUES (?,?)" area-name area-path))
+
+(define (pgdb:get-areas dbh)
+ ;; (map
+ ;; (lambda (row)
+ ;; (print "row: " row))
+ (dbi:get-rows dbh "SELECT id,area_name,area_path,last_sync FROM areas;")) ;; )
+
+;; given an area_path get the area info
+;;
+(define (pgdb:get-area-by-path dbh area-path)
+ (dbi:get-one-row dbh "SELECT id,area_name,area_path,last_sync FROM areas WHERE area_path=?;" area-path))
+
+(define (pgdb:write-sync-time dbh area-info new-sync-time)
+ (let ((area-id (vector-ref area-info 0)))
+ (dbi:exec dbh "UPDATE areas SET last_sync=? WHERE id=?;" new-sync-time area-id)))
+
+;;======================================================================
+;; T A R G E T S
+;;======================================================================
+
+;; Given a target-spec, return the id. Should probably handle this with a join...
+;; if target-spec not found, create a record for it.
+;;
+(define (pgdb:get-ttype dbh target-spec)
+ (let ((spec-id (dbi:get-one dbh "SELECT id FROM ttype WHERE target_spec=?;" target-spec)))
+ (or spec-id
+ (if (handle-exceptions
+ exn
+ (begin
+ (print-call-chain)
+ (debug:print 0 *default-log-port* "ERROR: cannot create ttype entry, " ((condition-property-accessor 'exn 'message) exn))
+ #f)
+ (dbi:exec dbh "INSERT INTO ttype (target_spec) VALUES (?);" target-spec))
+ (pgdb:get-ttype dbh target-spec)))))
+
+;;======================================================================
+;; T A G S
+;;======================================================================
+
+
+(define (pgdb:get-tag-info-by-name dbh tag)
+ (dbi:get-one-row dbh "SELECT id,tag_name FROM tags where tag_name=?;" tag))
+
+(define (pgdb:insert-tag dbh name )
+ (dbi:exec dbh "INSERT INTO tags (tag_name) VALUES (?)" name ))
+
+(define (pgdb:insert-area-tag dbh tag-id area-id )
+ (dbi:exec dbh "INSERT INTO area_tags (tag_id, area_id) VALUES (?,?)" tag-id area-id ))
+
+(define (pgdb:insert-run-tag dbh tag-id run-id )
+ (dbi:exec dbh "INSERT INTO run_tags (tag_id, run_id) VALUES (?,?)" tag-id run-id ))
+
+
+(define (pgdb:is-area-taged dbh area-id)
+ (let ((area-tag-id (dbi:get-one dbh "SELECT id FROM area_tags WHERE area_id=?;" area-id)))
+ (if area-tag-id
+ #t
+ #f)))
+
+(define (pgdb:is-area-taged-with-a-tag dbh tag-id area-id)
+ (let ((area-tag-id (dbi:get-one dbh "SELECT id FROM area_tags WHERE area_id=? and tag_id=?;" area-id tag-id)))
+ (if area-tag-id
+ #t
+ #f)))
+
+(define (pgdb:is-run-taged-with-a-tag dbh tag-id run-id)
+ (let ((run-tag-id (dbi:get-one dbh "SELECT id FROM run_tags WHERE run_id=? and tag_id=?;" run-id tag-id)))
+ (if run-tag-id
+ #t
+ #f)))
+
+
+
+;;======================================================================
+;; R U N S
+;;======================================================================
+
+;; given a target spec id, target and run-name return the run-id
+;; if no run found return #f
+;;
+(define (pgdb:get-run-id dbh spec-id target run-name area-id)
+ (dbi:get-one dbh "SELECT id FROM runs WHERE ttype_id=? AND target=? AND run_name=? and area_id=?;"
+ spec-id target run-name area-id))
+
+;; given a target spec id, target and run-name return the run-id
+;; if no run found return #f
+;;
+(define (pgdb:get-run-last-update dbh id )
+ (dbi:get-one dbh "SELECT last_update FROM runs WHERE id=?;"
+ id))
+
+;; given a run-id return all the run info
+;;
+(define (pgdb:get-run-info dbh run-id ) ;; to join ttype or not?
+ (dbi:get-one-row
+ dbh ;; 0 1 2 3 4 5 6 7 8 9 10 11 12
+ "SELECT id,target,ttype_id,run_name,state,status,owner,event_time,comment,fail_count,pass_count,last_update,area_id
+ FROM runs WHERE id=? ;" run-id ))
+
+;; refresh the data in a run record
+;;
+(define (pgdb:refresh-run-info dbh run-id state status owner event-time comment fail-count pass-count area-id last_update publish-time) ;; area-id)
+ (dbi:exec
+ dbh
+ "UPDATE runs SET
+ state=?,status=?,owner=?,event_time=?,comment=?,fail_count=?,pass_count=?,last_update=?,publish_time=?
+ WHERE id=? and area_id=?;"
+ state status owner event-time comment fail-count pass-count last_update publish-time run-id area-id ))
+
+;; given all needed info create run record
+;;
+(define (pgdb:insert-run dbh ttype-id target run-name state status owner event-time comment fail-count pass-count area-id last-update publish-time)
+ (dbi:exec
+ dbh
+ "INSERT INTO runs (ttype_id,target,run_name,state,status,owner,event_time,comment,fail_count,pass_count,area_id,last_update,publish_time)
+ VALUES (?,?,?,?,?,?,?,?,?,?,?,?, ?);"
+ ttype-id target run-name state status owner event-time comment fail-count pass-count area-id last-update publish-time))
+
+;;======================================================================
+;; T E S T - S T E P S
+;;======================================================================
+
+(define (pgdb:get-test-step-id dbh test-id stepname state)
+ (dbi:get-one
+ dbh
+ "SELECT id FROM test_steps WHERE test_id=? AND stepname=? and state = ? ;"
+ test-id stepname state))
+
+(define (pgdb:get-test-step-last-update dbh id )
+ (dbi:get-one
+ dbh
+ "SELECT last_update FROM test_steps WHERE id=? ;"
+ id))
+
+(define (pgdb:insert-test-step dbh test-id stepname state status event_time comment logfile last-update )
+ (dbi:exec
+ dbh
+ "INSERT INTO test_steps (test_id,stepname,state,status,event_time,logfile,comment,last_update)
+ VALUES (?,?,?,?,?,?,?,? );"
+ test-id stepname state status event_time logfile comment last-update))
+
+(define (pgdb:update-test-step dbh step-id test-id stepname state status event_time comment logfile last-update)
+ (dbi:exec
+ dbh
+ "UPDATE test_steps SET
+ test_id=?,stepname=?,state=?,status=?,event_time=?,logfile=?,comment=?,last_update=?
+ WHERE id=?;"
+ test-id stepname state status event_time logfile comment last-update step-id))
+
+
+;;======================================================================
+;; T E S T - D A T A
+;;======================================================================
+
+(define (pgdb:get-test-data-id dbh test-id category variable)
+ (dbi:get-one
+ dbh
+ "SELECT id FROM test_data WHERE test_id=? AND category=? and variable = ? ;"
+ test-id category variable))
+
+(define (pgdb:get-test-data-last-update dbh test-data-id )
+ (dbi:get-one
+ dbh
+ "SELECT last_update FROM test_data WHERE id=? ;"
+ test-data-id))
+
+(define (pgdb:insert-test-data dbh test-id category variable value expected tol units comment status type last-update)
+ ; (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, last_update)
+ VALUES (?,?,?,?,?,?,?,?,?,?, ?);"
+ test-id category variable value expected tol units comment status type last-update))
+
+(define (pgdb:update-test-data dbh data-id test-id category variable value expected tol units comment status type last-update)
+ (dbi:exec
+ dbh
+ "UPDATE test_data SET
+ test_id=?, category=?, variable=?, value=?, expected=?, tol=?, units=?, comment=?, status=?, type=?, last_update=?
+ WHERE id=?;"
+ test-id category variable value expected tol units comment status type last-update data-id ))
+
+
+
+;;======================================================================
+;; T E S T S
+;;======================================================================
+
+;; given run-id, test_name and item_path return test-id
+;;
+(define (pgdb:get-test-id dbh run-id test-name item-path)
+ (dbi:get-one
+ dbh
+ "SELECT id FROM tests WHERE run_id=? AND test_name=? AND item_path=?;"
+ run-id test-name item-path))
+
+(define (pgdb:get-test-last-update dbh id)
+ (dbi:get-one
+ dbh
+ "SELECT last_update FROM tests WHERE id=? ;"
+ id ))
+
+
+;; create new test record
+;;
+(define (pgdb:insert-test dbh run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived last-update pid)
+ (dbi:exec
+ dbh
+ "INSERT INTO tests (run_id,test_name,item_path,state,status,host,cpuload,diskfree,uname,rundir,final_logf,run_duration,comment,event_time,archived,last_update,attemptnum)
+ VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);"
+
+ run-id test-name item-path state status host cpuload diskfree uname
+ run-dir log-file run-duration comment event-time archived last-update pid))
+
+;; update existing test record
+;;
+(define (pgdb:update-test dbh test-id run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived last-update pid)
+ (dbi:exec
+ dbh
+ "UPDATE tests SET
+ run_id=?,test_name=?,item_path=?,state=?,status=?,host=?,cpuload=?,diskfree=?,uname=?,rundir=?,final_logf=?,run_duration=?,comment=?,event_time=?,archived=?,last_update=?,attemptnum=?
+ WHERE id=?;"
+
+ run-id test-name item-path state status host cpuload diskfree uname
+ run-dir log-file run-duration comment event-time archived last-update pid test-id))
+
+(define (pgdb:get-tests dbh target-patt)
+ (dbi:get-rows
+ dbh
+ "SELECT t.id,t.run_id,t.test_name,t.item_path,t.state,t.status,t.host,t.cpuload,t.diskfree,t.uname,t.rundir,t.final_logf,t.run_duration,t.comment,t.event_time,t.archived,
+ r.id,r.target,r.ttype_id,r.run_name,r.state,r.status,r.owner,r.event_time,r.comment
+ FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
+ WHERE r.target LIKE ?;" target-patt))
+
+(define (pgdb:get-stats-given-type-target dbh ttype-id target-patt)
+ (dbi:get-rows
+ dbh
+ ;; "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
+ ;; WHERE t.state='COMPLETED' AND ttype_id=? AND r.target LIKE ? GROUP BY r.target,t.status;"
+ "SELECT r.target,COUNT(*) AS total,
+ SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass,
+ SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail,
+ SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other
+ FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
+ WHERE t.state='COMPLETED' AND ttype_id=? AND r.target LIKE ? GROUP BY r.target;"
+ ttype-id target-patt))
+
+(define (pgdb:get-stats-given-target dbh target-patt)
+ (dbi:get-rows
+ dbh
+ ;; "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
+ ;; WHERE t.state='COMPLETED' AND ttype_id=? AND r.target LIKE ? GROUP BY r.target,t.status;"
+ "SELECT r.target,COUNT(*) AS total,
+ SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass,
+ SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail,
+ SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other
+ FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
+ WHERE t.state='COMPLETED' AND r.target LIKE ? GROUP BY r.target;"
+ target-patt))
+
+
+(define (pgdb:get-latest-run-stats-given-target dbh ttype-id target-patt limit offset)
+ (dbi:get-rows
+ dbh
+ ;; "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
+ ;; WHERE t.state='COMPLETED' AND ttype_id=? AND r.target LIKE ? GROUP BY r.target,t.status;"
+ "SELECT r.target, r.event_time, COUNT(*) AS total,
+ SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass,
+ SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail,
+ SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other, r.id
+ FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
+ WHERE t.state like '%' AND ttype_id=? AND r.target LIKE ?
+ and r.id in
+ (SELECT DISTINCT on (target) id from runs where target like ? AND ttype_id=? order by target,event_time desc)
+ GROUP BY r.target,r.id
+ order by r.event_time desc limit ? offset ? ;"
+ ttype-id target-patt target-patt ttype-id limit offset))
+
+(define (pgdb:get-latest-run-stats-given-pattern dbh patt limit offset)
+ (dbi:get-rows
+ dbh
+ ;; "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
+ ;; WHERE t.state='COMPLETED' AND ttype_id=? AND r.target ILIKE ? GROUP BY r.target,t.status;"
+ "SELECT r.target, r.event_time, COUNT(*) AS total,
+ SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass,
+ SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail,
+ SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other, r.id
+ FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
+ WHERE t.state like '%' AND r.target ILIKE ?
+ and r.id in
+ (SELECT DISTINCT on (target) id from runs where target ilike ? order by target,event_time desc)
+ GROUP BY r.target,r.id
+ order by r.event_time desc limit ? offset ? ;"
+ patt patt limit offset))
+
+
+(define (pgdb:get-count-data-stats-target-latest dbh ttype-id target-patt)
+ (dbi:get-rows
+ dbh
+ "SELECT count(*) from
+ (SELECT DISTINCT on (target) id
+ from runs where target like ? AND ttype_id = ?
+ order by target, event_time desc
+ ) as x;"
+ target-patt ttype-id))
+
+(define (pgdb:get-latest-run-cnt dbh ttype-id target-patt)
+ (let* ((cnt-result (pgdb:get-count-data-stats-target-latest dbh ttype-id target-patt))
+ ;(cnt-row (car (cnt-result)))
+ (cnt 0)
+ )
+ (for-each
+ (lambda (row)
+ (set! cnt (vector-ref row 0 )))
+ cnt-result)
+
+cnt))
+
+(define (pgdb:get-count-data-stats-latest-pattern dbh patt)
+ (dbi:get-rows
+ dbh
+ "SELECT count(*) from
+ (SELECT DISTINCT on (target) id
+ from runs where target ilike ?
+ order by target, event_time desc
+ ) as x;"
+ patt))
+
+(define (pgdb:get-latest-run-cnt-by-pattern dbh target-patt)
+ (let* ((cnt-result (pgdb:get-count-data-stats-latest-pattern dbh target-patt))
+ ;(cnt-row (car (cnt-result)))
+ (cnt 0)
+ )
+ (for-each
+ (lambda (row)
+ (set! cnt (vector-ref row 0 )))
+ cnt-result)
+
+cnt))
+
+
+
+
+
+(define (pgdb:get-run-stats-history-given-target dbh ttype-id target-patt)
+ (dbi:get-rows
+ dbh
+ ;; "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
+ ;; WHERE t.state='COMPLETED' AND ttype_id=? AND r.target LIKE ? GROUP BY r.target,t.status;"
+ "SELECT r.run_name,COUNT(*) AS total,
+ SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass,
+ SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail,
+ SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other
+ FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
+ WHERE t.state like '%' AND ttype_id=? AND r.target LIKE ?
+ GROUP BY r.run_name;"
+ ttype-id target-patt ))
+
+(define (pgdb:get-all-run-stats-target-slice dbh target-patt limit offset)
+ (dbi:get-rows
+ dbh
+ "SELECT r.target, r.run_name,r.event_time, COUNT(*) AS total,
+ SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass,
+ SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail,
+ SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other
+ FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
+ WHERE r.target LIKE ?
+ GROUP BY r.target,r.run_name, r.event_time
+ order by r.target,r.event_time desc limit ? offset ? ;"
+ target-patt limit offset))
+
+
+(define (pgdb:get-count-data-stats-target-slice dbh target-patt)
+ (dbi:get-rows
+ dbh
+ "SELECT count(*) from (SELECT r.target, r.run_name,r.event_time, COUNT(*) AS total
+ FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id
+ WHERE r.target LIKE ?
+ GROUP BY r.target,r.run_name, r.event_time
+ ) as x;"
+ target-patt))
+
+(define (pgdb:get-slice-cnt dbh target-patt)
+ (let* ((cnt-result (pgdb:get-count-data-stats-target-slice dbh target-patt))
+ ;(cnt-row (car (cnt-result)))
+ (cnt 0)
+ )
+ (for-each
+ (lambda (row)
+ (set! cnt (vector-ref row 0 )))
+ cnt-result)
+
+cnt))
+
+
+(define (pgdb:get-target-types dbh)
+ (dbi:get-rows dbh "SELECT id,target_spec FROM ttype;"))
+
+ (define (pgdb:get-distict-target-slice dbh)
+ (dbi:get-rows dbh " select distinct on (split_part (target, '/', 1)) (split_part (target, '/', 1)) from runs;"))
+
+ (define (pgdb:get-distict-target-slice3 dbh)
+ (dbi:get-rows dbh " select distinct on (split_part (target, '/', 3)) (split_part (target, '/', 3)) from runs;"))
+;;
+(define (pgdb:get-targets dbh target-patt)
+ (let ((ttypes (pgdb:get-target-types dbh)))
+ (map
+ (lambda (ttype-dat)
+ (let ((tt-id (vector-ref ttype-dat 0))
+ (ttype (vector-ref ttype-dat 1)))
+ (cons ttype
+ (dbi:get-rows
+ dbh
+ "SELECT DISTINCT target FROM runs WHERE target LIKE ? AND ttype_id=?;" target-patt tt-id))
+ ))
+ ttypes)))
+
+(define (pgdb:get-targets-of-type dbh ttype-id target-patt)
+ (dbi:get-rows dbh "SELECT DISTINCT target FROM runs WHERE target LIKE ? AND ttype_id=?;" target-patt ttype-id))
+
+(define (pgdb:get-runs-by-target dbh targets run-patt)
+ (dbi:get-rows dbh "SELECT r.run_name, t.test_name, t.status, t.item_path, t.id, t.rundir, t.final_logf FROM runs as r INNER JOIN tests AS t ON t.run_id=r.id
+ WHERE t.state='COMPLETED' AND r.target like ? AND r.run_name like ?;" targets run-patt)
+)
+
+(define (pgdb:get-test-by-id dbh id)
+ (dbi:get-rows dbh "SELECT t.test_name, t.item_path, t.rundir, t.final_logf FROM runs as r INNER JOIN tests AS t ON t.run_id=r.id
+ WHERE t.id = ?;" id)
+)
+
+;;======================================================================
+;; V A R I O U S D A T A M A S S A G E R O U T I N E S
+;;======================================================================
+
+;; probably want to move these to a different model file
+
+;; create a hash of hashes with keys extracted from all-parts
+;; using row-or-col to choose row or column
+;; ht{row key}=>ht{col key}=>data
+;;
+;; fnum is the field number in the tuples to be split
+;;
+
+(define (pgdb:mk-pattern dot type bp rel)
+ (let* ((typ (if (equal? type "all")
+ "%"
+ type))
+ (dotprocess (if (equal? dot "all")
+ "%"
+ dot))
+ (rel-num (if (equal? rel "")
+ "%"
+ rel))
+ (pattern (conc "%/" bp "/" dotprocess "/" typ "_" rel-num)))
+pattern))
+
+(define (pgdb:coalesce-runs dbh runs all-parts row-or-col fnum)
+ (let* ((data (make-hash-table)))
+
+ (for-each
+ (lambda (run)
+ (let* ((target (vector-ref run fnum))
+ (parts (string-split target "/"))
+ (first (car parts))
+ (rest (string-intersperse (cdr parts) "/"))
+ (coldat (hash-table-ref/default data first #f)))
+ (if (not coldat)(let ((newht (make-hash-table)))
+ (hash-table-set! data first newht)
+ (set! coldat newht)))
+ (hash-table-set! coldat rest run)))
+ runs)
+ data))
+
+
+(define (pgdb:coalesce-runs1 runs )
+ (let* ((data (make-hash-table)))
+
+ (for-each
+ (lambda (run)
+ (let* ((target (vector-ref run 0))
+ (parts (string-split target "/"))
+ (first (car parts))
+ (rest (string-intersperse (cdr parts) "/"))
+ (coldat (hash-table-ref/default data first #f)))
+ (if (not coldat)(let ((newht (make-hash-table)))
+ (hash-table-set! data first newht)
+ (set! coldat newht)))
+ (hash-table-set! coldat rest run)))
+ runs)
+ data))
+
+;; given ordered data hash return a-keys
+;;
+(define (pgdb:ordered-data->a-keys ordered-data)
+ (sort (hash-table-keys ordered-data) string>=?))
+
+;; given ordered data hash return b-keys
+;;
+(define (pgdb:ordered-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>=?)))
+
+;; given ordered data hash return a-keys
+;;
+(define (pgdb:ordered-data->a-keys ordered-data)
+ (sort (hash-table-keys ordered-data) string>=?))
+
+;; given ordered data hash return b-keys
+;;
+(define (pgdb:ordered-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 (pgdb:coalesce-runs-by-slice runs slice)
+ (let* ((data (make-hash-table)))
+ (for-each
+ (lambda (run)
+ (let* ((target (vector-ref run 0))
+ (run-name (vector-ref run 1))
+ (parts (string-split target "/"))
+ (first (car parts))
+ (rest (string-intersperse (cdr parts) "/"))
+ (coldat (hash-table-ref/default data rest #f)))
+ (if (not coldat)(let ((newht (make-hash-table)))
+ (hash-table-set! data rest newht)
+ (set! coldat newht)))
+ (hash-table-set! coldat run-name run)))
+ runs)
+ data))
+
+
+(define (pgdb:runs-to-hash runs )
+ (let* ((data (make-hash-table)))
+ (for-each
+ (lambda (run)
+ (let* ((run-name (vector-ref run 0))
+ (test (conc (vector-ref run 1) ":" (vector-ref run 3)))
+ (coldat (hash-table-ref/default data run-name #f)))
+ (if (not coldat)(let ((newht (make-hash-table)))
+ (hash-table-set! data run-name newht)
+ (set! coldat newht)))
+ (hash-table-set! coldat test run)))
+ runs)
+ data))
+
+(define (pgdb:get-history-hash runs)
+ (let* ((data (make-hash-table)))
+ (for-each
+ (lambda (run)
+ (let* ((run-name (vector-ref run 0)))
+ (hash-table-set! data run-name run)))
+ runs)
+ data))
+
+(define (pgdb:get-pg-lst tab2-pages)
+ (let loop ((i 1)
+ (lst `()))
+ (cond
+ ((> i tab2-pages )
+ lst)
+ (else
+ (loop (+ i 1) (append lst (list i)))))))
+
DELETED records-vs-vectors-vs-coops.scm
Index: records-vs-vectors-vs-coops.scm
==================================================================
--- records-vs-vectors-vs-coops.scm
+++ /dev/null
@@ -1,110 +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 "vg.scm")
-
-;; (declare (uses vg))
-
-(use foof-loop defstruct coops)
-
-(defstruct obj type fill-color angle)
-
-(define (make-vg:obj)(make-vector 3))
-(define-inline (vg:obj-get-type vec) (vector-ref vec 0))
-(define-inline (vg:obj-get-fill-color vec) (vector-ref vec 1))
-(define-inline (vg:obj-get-angle vec) (vector-ref vec 2))
-(define-inline (vg:obj-set-type! vec val)(vector-set! vec 0 val))
-(define-inline (vg:obj-set-fill-color! vec val)(vector-set! vec 1 val))
-(define-inline (vg:obj-set-angle! vec val)(vector-set! vec 2 val))
-
-(use simple-exceptions)
-(define vgs:obj-exn (make-exception "wrong record type, expected vgs:obj." 'assert))
-(define (make-vgs:obj)(let ((v (make-vector 4)))(vector-set! v 0 'vgs:obj) v))
-(define-inline (vgs:obj-type vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 1)(raise (vgs:obj-exn 'vgs:obj-type 'xpr))))
-(define-inline (vgs:obj-fill-color vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 2)(raise (vgs:obj-exn 'vgs:obj-fill-color 'xpr))))
-(define-inline (vgs:obj-angle vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 3)(raise (vgs:obj-exn 'vgs:obj-angle 'xpr))))
-(define-inline (vgs:obj-type-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 1 val)(raise (vgs:obj-exn 'type))))
-(define-inline (vgs:obj-fill-color-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 2 val)(raise (vgs:obj-exn 'fill-color))))
-(define-inline (vgs:obj-angle-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 3 val)(raise (vgs:obj-exn 'angle))))
-
-(define-class ()
- ((type)
- (fill-color)
- (angle)))
-
-
-;; first use raw vectors
-(print "Using vectors")
-(time
- (loop ((for r (up-from 0 (to 255))))
- (loop ((for g (up-from 0 (to 255))))
- (loop ((for b (up-from 0 (to 255))))
- (let ((obj (make-vg:obj)))
- (vg:obj-set-type! obj 'abc)
- (vg:obj-set-fill-color! obj "green")
- (vg:obj-set-angle! obj 135)
- (let ((a (vg:obj-get-type obj))
- (b (vg:obj-get-fill-color obj))
- (c (vg:obj-get-angle obj)))
- obj))))))
-
-;; first use raw vectors with safe mode
-(print "Using vectors (safe mode)")
-(time
- (loop ((for r (up-from 0 (to 255))))
- (loop ((for g (up-from 0 (to 255))))
- (loop ((for b (up-from 0 (to 255))))
- (let ((obj (make-vgs:obj)))
- ;; (badobj (make-vector 20)))
- (vgs:obj-type-set! obj 'abc)
- (vgs:obj-fill-color-set! obj "green")
- (vgs:obj-angle-set! obj 135)
- (let ((a (vgs:obj-type obj))
- (b (vgs:obj-fill-color obj))
- (c (vgs:obj-angle obj)))
- obj))))))
-
-;; first use defstruct
-(print "Using defstruct")
-(time
- (loop ((for r (up-from 0 (to 255))))
- (loop ((for g (up-from 0 (to 255))))
- (loop ((for b (up-from 0 (to 255))))
- (let ((obj (make-obj)))
- (obj-type-set! obj 'abc)
- (obj-fill-color-set! obj "green")
- (obj-angle-set! obj 135)
- (let ((a (obj-type obj))
- (b (obj-fill-color obj))
- (c (obj-angle obj)))
- obj))))))
-
-
-;; first use defstruct
-(print "Using coops")
-(time
- (loop ((for r (up-from 0 (to 255))))
- (loop ((for g (up-from 0 (to 255))))
- (loop ((for b (up-from 0 (to 255))))
- (let ((obj (make )))
- (set! (slot-value obj 'type) 'abc)
- (set! (slot-value obj 'fill-color) "green")
- (set! (slot-value obj 'angle) 135)
- (let ((a (slot-value obj 'type))
- (b (slot-value obj 'fill-color))
- (c (slot-value obj 'angle)))
- obj))))))
Index: rmt-inc.scm
==================================================================
--- rmt-inc.scm
+++ rmt-inc.scm
@@ -332,11 +332,11 @@
(resdat (if (not (and read-only qry-is-write))
(let ((v (api:execute-requests dbstruct-local (vector (symbol->string cmd) params))))
(handle-exceptions ;; there has been a long history of receiving strange errors from values returned by the client when things go wrong..
exn ;; This is an attempt to detect that situation and recover gracefully
(begin
- (debug:print0 *default-log-port* "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn))
+ (debug:print 0 *default-log-port* "ERROR: bad data from server " v " message: " ((condition-property-accessor 'exn 'message) exn))
(vector #t '())) ;; should always get a vector but if something goes wrong return a dummy
(if (and (vector? v)
(> (vector-length v) 1))
(let ((newvec (vector (vector-ref v 0)(vector-ref v 1))))
newvec) ;; by copying the vector while inside the error handler we should force the detection of a corrupted record
@@ -515,11 +515,11 @@
#f)))
(define (rmt:test-get-rundir-from-test-id run-id test-id)
(rmt:send-receive 'test-get-rundir-from-test-id run-id (list run-id test-id)))
-(define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f))
+#;(define (rmt:open-test-db-by-test-id run-id test-id #!key (work-area #f))
(let* ((test-path (if (string? work-area)
work-area
(rmt:test-get-rundir-from-test-id run-id test-id))))
(debug:print 3 *default-log-port* "TEST PATH: " test-path)
(open-test-db test-path)))
@@ -921,10 +921,68 @@
(rmt:send-receive 'test-set-archive-block-id run-id (list run-id test-id archive-block-id)))
(define (rmt:test-get-archive-block-info archive-block-id)
(rmt:send-receive 'test-get-archive-block-info #f (list archive-block-id)))
-(set-functions rmt:send-receive remote-server-url-set!
+#;(set-functions rmt:send-receive remote-server-url-set!
http-transport:close-connections remote-conndat-set!
debug:print debug:print-info
remote-ro-mode remote-ro-mode-set!
remote-ro-mode-checked-set! remote-ro-mode-checked)
+
+(define (rmtmod:calc-ro-mode runremote *toppath*)
+ (if (and runremote
+ (remote-ro-mode-checked runremote))
+ (remote-ro-mode runremote)
+ (let* ((dbfile (conc *toppath* "/megatest.db"))
+ (ro-mode (not (file-write-access? dbfile)))) ;; TODO: use dbstruct or runremote to figure this out in future
+ (if runremote
+ (begin
+ (remote-ro-mode-set! runremote ro-mode)
+ (remote-ro-mode-checked-set! runremote #t)
+ ro-mode)
+ ro-mode))))
+
+(define (extras-readonly-mode rmt-mutex log-port cmd params)
+ (mutex-unlock! rmt-mutex)
+ (debug:print-info 12 log-port "rmt:send-receive, case 3")
+ (debug:print 0 log-port "WARNING: write transaction requested on a readonly area. cmd="cmd" params="params)
+ #f)
+
+(define (extras-transport-failed *default-log-port* *rmt-mutex* attemptnum runremote cmd rid params)
+ (debug:print 0 *default-log-port* "WARNING: communication failed. Trying again, try num: " attemptnum)
+ (mutex-lock! *rmt-mutex*)
+ (remote-conndat-set! runremote #f)
+ (http-transport:close-connections area-dat: runremote)
+ (remote-server-url-set! runremote #f)
+ (mutex-unlock! *rmt-mutex*)
+ (debug:print-info 12 *default-log-port* "rmt:send-receive, case 9.1")
+ (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))
+
+(define (extras-transport-succeded *default-log-port* *rmt-mutex* attemptnum runremote res params rid cmd)
+ (if (and (vector? res)
+ (eq? (vector-length res) 2)
+ (eq? (vector-ref res 1) 'overloaded)) ;; since we are
+ ;; looking at the
+ ;; data to carry the
+ ;; error we'll use a
+ ;; fairly obtuse
+ ;; combo to minimise
+ ;; the chances of
+ ;; some sort of
+ ;; collision. this
+ ;; is the case where
+ ;; the returned data
+ ;; is bad or the
+ ;; server is
+ ;; overloaded and we
+ ;; want to ease off
+ ;; the queries
+ (let ((wait-delay (+ attemptnum (* attemptnum 10))))
+ (debug:print 0 *default-log-port* "WARNING: server is overloaded. Delaying " wait-delay " seconds and trying call again.")
+ (mutex-lock! *rmt-mutex*)
+ (http-transport:close-connections area-dat: runremote)
+ (set! *runremote* #f) ;; force starting over
+ (mutex-unlock! *rmt-mutex*)
+ (thread-sleep! wait-delay)
+ (rmt:send-receive cmd rid params attemptnum: (+ attemptnum 1)))
+ res)) ;; All good, return res
Index: runs-inc.scm
==================================================================
--- runs-inc.scm
+++ runs-inc.scm
@@ -364,11 +364,12 @@
(waitors-upon (make-hash-table)) ;; given a test, return list of tests waiting upon this test.
(task-key (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id)))
;; (tdbdat (tasks:open-db))
(config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns")))
(if x (string->number x) #f)))
- (allowed-tests #f))
+ (allowed-tests #f)
+ (runconf #f))
;; check if readonly
(when readonly-mode
(debug:print-error 0 *default-log-port* "megatest.db is readonly. Cannot proceed.")
(exit 1))
@@ -2557,11 +2558,11 @@
(hash-table-keys test-names))))
;; This could probably be refactored into one complex query ...
;; NOT PORTED - DO NOT USE YET
;;
-(define (runs:rollup-run keys runname user keyvals)
+#;(define (runs:rollup-run keys runname user keyvals)
(debug:print 4 *default-log-port* "runs:rollup-run, keys: " keys " -runname " runname " user: " user)
(let* ((db #f)
;; register run operates on the main db
(new-run-id (rmt:register-run keyvals runname "new" "n/a" user (args:get-arg "-contour")))
(prev-tests (rmt:get-matching-previous-test-run-records new-run-id "%" "%"))
Index: tasks-inc.scm
==================================================================
--- tasks-inc.scm
+++ tasks-inc.scm
@@ -99,11 +99,11 @@
(mdb (cond ;; what the hek is *toppath* doing here?
((and (string? *toppath*)(file-write-access? *toppath*))
(sqlite3:open-database dbfile))
((file-read-access? dbpath) (sqlite3:open-database dbfile))
(else (sqlite3:open-database ":memory:")))) ;; (never-give-up-open-db dbpath))
- (handler (make-busy-timeout 36000)))
+ (handler (sqlite3:make-busy-timeout 36000)))
(if (and exists
(not write-access))
(set! *db-write-access* write-access)) ;; only unset so other db's also can use this control
(sqlite3:set-busy-handler! mdb handler)
(db:set-sync mdb) ;; (sqlite3:execute mdb (conc "PRAGMA synchronous = 0;"))
@@ -265,11 +265,11 @@
"SELECT count(id) FROM monitors WHERE last_update < (strftime('%s','now') - 300) AND username=?;"
(car (user-information (current-user-id))))
res))
;;
-(define (tasks:start-monitor db mdb)
+#;(define (tasks:start-monitor db mdb)
(if (> (tasks:get-num-alive-monitors mdb) 2) ;; have two running, no need for more
(debug:print-info 1 *default-log-port* "Not starting monitor, already have more than two running")
(let* ((megatestdb (conc *toppath* "/megatest.db"))
(monitordbf (conc (db:dbfile-path #f) "/monitor.db"))
(last-db-update 0)) ;; (file-modification-time megatestdb)))
@@ -429,23 +429,23 @@
(db:with-db
dbstruct #f #t
(lambda (db)
(sqlite3:execute db (conc "DELETE FROM tasks_queue WHERE id IN (" task-ids ");")))))
-(define (tasks:process-queue dbstruct)
+#;(define (tasks:process-queue dbstruct)
(let* ((task (tasks:snag-a-task dbstruct))
(action (if task (tasks:task-get-action task) #f)))
(if action (print "tasks:process-queue task: " task))
(if action
(case (string->symbol action)
((run) (tasks:start-run dbstruct task))
((remove) (tasks:remove-runs dbstruct task))
((lock) (tasks:lock-runs dbstruct task))
;; ((monitor) (tasks:start-monitor db task))
- ((rollup) (tasks:rollup-runs dbstruct task))
+ #;((rollup) (tasks:rollup-runs dbstruct task))
((updatemeta)(tasks:update-meta dbstruct task))
- ((kill) (tasks:kill-monitors dbstruct task))))))
+ #;((kill) (tasks:kill-monitors dbstruct task))))))
(define (tasks:tasks->text tasks)
(let ((fmtstr "~10a~10a~10a~12a~20a~12a~12a~10a"))
(conc (format #f fmtstr "id" "action" "owner" "state" "target" "runname" "testpatts" "params") "\n"
(string-intersperse
@@ -455,11 +455,11 @@
(tasks:task-get-action task)
(tasks:task-get-owner task)
(tasks:task-get-state task)
(tasks:task-get-target task)
(tasks:task-get-name task)
- (tasks:task-get-test task)
+ (tasks:task-get-testpatt task)
;; (tasks:task-get-item task)
(tasks:task-get-params task)))
tasks) "\n"))))
(define (tasks:set-state dbstruct task-id state)
Index: tests-inc.scm
==================================================================
--- tests-inc.scm
+++ tests-inc.scm
@@ -1908,11 +1908,11 @@
(uname (get-uname "-srvpio"))
(hostname (get-host-name)))
(tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname)))
;; (define (tests:set-partial-meta-info test-id run-id minutes work-area)
-(define (tests:set-partial-meta-info test-id run-id minutes work-area remtries)
+#;(define (tests:set-partial-meta-info test-id run-id minutes work-area remtries)
(let* ((cpuload (get-cpu-load))
(diskfree (get-df (current-directory)))
(remtries 10))
(handle-exceptions
exn
Index: vg-inc.scm
==================================================================
--- vg-inc.scm
+++ vg-inc.scm
@@ -555,11 +555,11 @@
;; (begin
;; (canvas-foreground-set! cnv fill-color)
;; (canvas-box! cnv llx ulx lly uly))) ;; docs are all over the place on this one.;; w h)
(if line-color
(canvas-foreground-set! cnv line-color)
- (if fill-color
+ #;(if fill-color
(canvas-foreground-set! cnv prev-foreground-color)))
(canvas-line! cnv llx ulx lly uly)
(canvas-foreground-set! cnv prev-foreground-color)
(if text
(let* ((prev-font (canvas-font cnv))