Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -19,19 +19,20 @@ # rm .o ; make install CSCOPTS='-profile' ; ... ; chicken-profile | less SHELL=/bin/bash PREFIX=$(PWD) CSCOPTS= INSTALL=install -#SRCFILES = common.scm items.scm launch.scm \ -# ods.scm runconfig.scm server.scm configf.scm \ -# db.scm keys.scm margs.scm megatest-version.scm \ -# process.scm runs.scm tasks.scm tests.scm genexample.scm \ -# http-transport.scm filedb.scm tdb.scm \ -# client.scm mt.scm \ -# ezsteps.scm lock-queue.scm sdb.scm \ -# rmt.scm api.scm subrun.scm \ -# portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm +DELFILES = common.scm items.scm launch.scm \ + ods.scm runconfig.scm server.scm configf.scm \ + db.scm keys.scm margs.scm megatest-version.scm \ + process.scm runs.scm tasks.scm tests.scm genexample.scm \ + http-transport.scm filedb.scm tdb.scm \ + client.scm mt.scm \ + ezsteps.scm lock-queue.scm sdb.scm \ + rmt.scm api.scm subrun.scm \ + portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm + SRCFILES= # removed from MSRCFILES: ftail.scm # module source files @@ -240,11 +241,11 @@ megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi -$(OFILES) $(GOFILES) : common_records.scm +$(MOFILES) $(OFILES) $(GOFILES) : common_records.scm %.o : %.scm $(MOFILES) csc $(CSCOPTS) -c $< $(MOFILES) $(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest utils/mk_wrapper @@ -523,5 +524,10 @@ @grep : Makefile | perl -ne '/^([A-Za-z0-9_-]+):/ && print "$$1\n"' unit : cd tests;make unit + +delfiles : + mv $(DELFILES) attic + fossil mv $(DELFILES) attic + DELETED api.scm Index: api.scm ================================================================== --- api.scm +++ /dev/null @@ -1,33 +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 srfi-69 posix) - -(declare (unit api)) -;; (declare (uses rmt)) -(declare (uses db)) -(declare (uses tasks)) - -(declare (uses apimod)) -(import apimod) - -;; api:read-only-queries and api:execute-requests have been moved into common_records - - DELETED archive.scm Index: archive.scm ================================================================== --- archive.scm +++ /dev/null @@ -1,32 +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') - -(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18) - -(declare (unit archive)) -(declare (uses db)) -(declare (uses common)) - -(declare (uses commonmod)) -(import commonmod) - -(include "common_records.scm") -(include "db_records.scm") - ADDED attic/api.scm Index: attic/api.scm ================================================================== --- /dev/null +++ attic/api.scm @@ -0,0 +1,33 @@ +;;====================================================================== +;; 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 srfi-69 posix) + +(declare (unit api)) +;; (declare (uses rmt)) +(declare (uses db)) +(declare (uses tasks)) + +(declare (uses apimod)) +(import apimod) + +;; api:read-only-queries and api:execute-requests have been moved into common_records + + ADDED attic/archive.scm Index: attic/archive.scm ================================================================== --- /dev/null +++ attic/archive.scm @@ -0,0 +1,32 @@ +;; 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') + +(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18) + +(declare (unit archive)) +(declare (uses db)) +(declare (uses common)) + +(declare (uses commonmod)) +(import commonmod) + +(include "common_records.scm") +(include "db_records.scm") + ADDED attic/client.scm Index: attic/client.scm ================================================================== --- /dev/null +++ attic/client.scm @@ -0,0 +1,38 @@ + +;; 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 . + +;;====================================================================== +;; C L I E N T S +;;====================================================================== + +(use srfi-18 extras tcp s11n srfi-1 posix regex srfi-69 hostinfo md5 + message-digest matchable spiffy uri-common intarweb http-client + spiffy-request-vars uri-common intarweb directory-utils) + +(declare (unit client)) + +(declare (uses common)) +(declare (uses db)) +(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. +(declare (uses commonmod)) +(import commonmod) + + +(include "common_records.scm") +(include "db_records.scm") + ADDED attic/common.scm Index: attic/common.scm ================================================================== --- /dev/null +++ attic/common.scm @@ -0,0 +1,35 @@ +;;====================================================================== +;; 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 . + +;;====================================================================== + +(use srfi-1 data-structures posix regex-case (prefix base64 base64:) + format dot-locking csv-xml z3 udp ;; sql-de-lite + hostinfo md5 message-digest typed-records directory-utils stack + matchable regex posix (srfi 18) extras ;; tcp + (prefix nanomsg nmsg:) + (prefix sqlite3 sqlite3:) + pkts (prefix dbi dbi:) + ) + +(declare (unit common)) +(declare (uses commonmod)) +(import commonmod) + +(include "common_records.scm") + ADDED attic/configf.scm Index: attic/configf.scm ================================================================== --- /dev/null +++ attic/configf.scm @@ -0,0 +1,32 @@ +;;====================================================================== +;; 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 . + +;;====================================================================== + +;;====================================================================== +;; Config file handling +;;====================================================================== + +(use regex regex-case) ;; directory-utils) +(declare (unit configf)) +(declare (uses process)) +(declare (uses env)) +(declare (uses keys)) + +(include "common_records.scm") + ADDED attic/db.scm Index: attic/db.scm ================================================================== --- /dev/null +++ attic/db.scm @@ -0,0 +1,55 @@ +;====================================================================== +;; 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 . +;; +;;====================================================================== + +;;====================================================================== +;; Database access +;;====================================================================== + +;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc + +(use (srfi 18) extras tcp stack) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records matchable) +(import (prefix sqlite3 sqlite3:)) +(import (prefix base64 base64:)) + +(declare (unit db)) +(declare (uses common)) +(declare (uses keys)) +(declare (uses ods)) +(declare (uses client)) +(declare (uses mt)) + +(include "common_records.scm") +(include "db_records.scm") +(include "key_records.scm") +(include "run_records.scm") + +(declare (uses rmtmod)) +(import rmtmod) +(declare (uses dbmod)) +(import dbmod) +(declare (uses commonmod)) +(import commonmod) + +(define *rundb-mutex* (make-mutex)) ;; prevent problems opening/closing rundb's +(define *number-of-writes* 0) +(define *number-non-write-queries* 0) + +(set-fn 'db:setup dbmod#db:setup) ADDED attic/diff-report.scm Index: attic/diff-report.scm ================================================================== --- /dev/null +++ attic/diff-report.scm @@ -0,0 +1,26 @@ +;; 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) ADDED attic/env.scm Index: attic/env.scm ================================================================== --- /dev/null +++ attic/env.scm @@ -0,0 +1,24 @@ +;;====================================================================== +;; 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) + ADDED attic/ezsteps.scm Index: attic/ezsteps.scm ================================================================== --- /dev/null +++ attic/ezsteps.scm @@ -0,0 +1,43 @@ + +;; 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) + +(declare (unit ezsteps)) +(declare (uses db)) +(declare (uses common)) +(declare (uses items)) +(declare (uses runconfig)) +(declare (uses commonmod)) +(import commonmod) + +;; (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 + + ADDED attic/filedb.scm Index: attic/filedb.scm ================================================================== --- /dev/null +++ attic/filedb.scm @@ -0,0 +1,255 @@ +;; 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))) + ADDED attic/genexample.scm Index: attic/genexample.scm ================================================================== --- /dev/null +++ attic/genexample.scm @@ -0,0 +1,23 @@ +;;====================================================================== +;; 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) + ADDED attic/http-transport.scm Index: attic/http-transport.scm ================================================================== --- /dev/null +++ attic/http-transport.scm @@ -0,0 +1,43 @@ + +;; 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) + +(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 portlogger)) +(declare (uses rmt)) + +(declare (uses commonmod)) +(import commonmod) + +(include "common_records.scm") +(include "db_records.scm") +(include "js-path.scm") + +(require-library stml) ADDED attic/items.scm Index: attic/items.scm ================================================================== --- /dev/null +++ attic/items.scm @@ -0,0 +1,30 @@ + +;; 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)) +(declare (uses commonmod)) +(import commonmod) + + +(include "common_records.scm") ADDED attic/keys.scm Index: attic/keys.scm ================================================================== --- /dev/null +++ attic/keys.scm @@ -0,0 +1,39 @@ + +;; 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)) +(declare (uses commonmod)) +(import commonmod) + + +(include "key_records.scm") +(include "common_records.scm") +;;====================================================================== +;; config file related routines +;;====================================================================== + +;; (define keys:config-get-fields common:get-fields) ADDED attic/launch.scm Index: attic/launch.scm ================================================================== --- /dev/null +++ attic/launch.scm @@ -0,0 +1,42 @@ + +;; 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 commonmod)) +(import commonmod) + +(include "common_records.scm") +(include "key_records.scm") +(include "db_records.scm") + ADDED attic/lock-queue.scm Index: attic/lock-queue.scm ================================================================== --- /dev/null +++ attic/lock-queue.scm @@ -0,0 +1,26 @@ +;; 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)) +(declare (uses commonmod)) +(import commonmod) + ADDED attic/margs.scm Index: attic/margs.scm ================================================================== --- /dev/null +++ attic/margs.scm @@ -0,0 +1,21 @@ +;; 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)) + ADDED attic/mt.scm Index: attic/mt.scm ================================================================== --- /dev/null +++ attic/mt.scm @@ -0,0 +1,42 @@ +;; 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)) +(declare (uses commonmod)) +(import commonmod) + + +(include "common_records.scm") +(include "key_records.scm") +(include "db_records.scm") +(include "run_records.scm") +(include "test_records.scm") + ADDED attic/ods.scm Index: attic/ods.scm ================================================================== --- /dev/null +++ attic/ods.scm @@ -0,0 +1,25 @@ +;; 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)) +(declare (uses commonmod)) +(import commonmod) + + ADDED attic/pgdb.scm Index: attic/pgdb.scm ================================================================== --- /dev/null +++ attic/pgdb.scm @@ -0,0 +1,656 @@ +;;====================================================================== +;; 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 pgdb)) +(declare (uses configf)) + +;; 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) + +(use typed-records (prefix dbi dbi:)) + +;; 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))))))) + ADDED attic/portlogger.scm Index: attic/portlogger.scm ================================================================== --- /dev/null +++ attic/portlogger.scm @@ -0,0 +1,28 @@ + +;; 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 . +;; + +(require-extension (srfi 18) extras tcp s11n) + +(use sqlite3 srfi-1 posix srfi-69 hostinfo dot-locking z3) +(import (prefix sqlite3 sqlite3:)) + +(declare (unit portlogger)) +(declare (uses db)) + +;; lsof -i ADDED attic/process.scm Index: attic/process.scm ================================================================== --- /dev/null +++ attic/process.scm @@ -0,0 +1,27 @@ +;;====================================================================== +;; 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 . + +;;====================================================================== + +;;====================================================================== +;; Process convience utils +;;====================================================================== + +(use regex directory-utils) +(declare (unit process)) + ADDED attic/rmt.scm Index: attic/rmt.scm ================================================================== --- /dev/null +++ attic/rmt.scm @@ -0,0 +1,44 @@ +;;====================================================================== +;; 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 format typed-records) ;; RADT => purpose of json format?? + +(declare (unit rmt)) +(declare (uses api)) +(declare (uses http-transport)) +(include "common_records.scm") + +(declare (uses rmtmod)) +(import rmtmod) +(declare (uses commonmod)) +(import commonmod) + +(set-fn 'server:expiration-timeout server:expiration-timeout) +(set-fn 'common:get-homehost common:get-homehost) +(set-fn 'server:check-if-running server:check-if-running) +(set-fn 'api:execute-requests api:execute-requests) +(set-fn 'http-transport:close-connections http-transport:close-connections ) +(set-fn 'http-transport:client-api-send-receive http-transport:client-api-send-receive) +(set-fn 'server:kind-run server:kind-run) +(set-fn 'server:start-and-wait server:start-and-wait) +(set-fn 'server:check-if-running server:check-if-running) +(set-fn 'server:ping server:ping ) +(set-fn 'common:force-server? common:force-server? ) + ADDED attic/runconfig.scm Index: attic/runconfig.scm ================================================================== --- /dev/null +++ attic/runconfig.scm @@ -0,0 +1,43 @@ +;; 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 . + +;;====================================================================== +;; read a config file, loading only the section pertinent +;; to this run field1val/field2val/field3val ... +;;====================================================================== + +(use format directory-utils) + +(declare (unit runconfig)) +(declare (uses common)) + +(include "common_records.scm") + + +#| + (if (null? target-strs) + '() + (let loop ((hed (car target-strs)) + (tal (cdr target-strs)) + (res '())) + ;; first break all parts into individual target patterns + (if (string-index hed " ") ;; this is a multi-target target + (let ((newres (append (string-split hed " ") res))) + (runconfig:expand-target newres)) + (if (string-index hed ",") ;; this is a multi-target where one or more parts are comma separated + +|# ADDED attic/runs.scm Index: attic/runs.scm ================================================================== --- /dev/null +++ attic/runs.scm @@ -0,0 +1,42 @@ +;; 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 . + +;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') + +(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) + posix-extras directory-utils pathname-expand typed-records format) + +(declare (unit runs)) +(declare (uses db)) +(declare (uses common)) +(declare (uses items)) +(declare (uses runconfig)) +(declare (uses tests)) +(declare (uses server)) +(declare (uses mt)) +(declare (uses archive)) +;; (declare (uses filedb)) + +(declare (uses commonmod)) +(import commonmod) + +(include "common_records.scm") +(include "key_records.scm") +(include "db_records.scm") +(include "run_records.scm") +(include "test_records.scm") + ADDED attic/sdb.scm Index: attic/sdb.scm ================================================================== --- /dev/null +++ attic/sdb.scm @@ -0,0 +1,32 @@ +;;====================================================================== +;; 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 . + +;;====================================================================== + +;;====================================================================== +;; Simple persistant strings lookup table. Keep out of the main db +;; so writes/reads don't slow down central access. +;;====================================================================== + +(require-extension (srfi 18) extras) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) +(import (prefix sqlite3 sqlite3:)) +(import (prefix base64 base64:)) + +(declare (unit sdb)) + ADDED attic/server.scm Index: attic/server.scm ================================================================== --- /dev/null +++ attic/server.scm @@ -0,0 +1,40 @@ + +;; 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 . +;; + +(require-extension (srfi 18) extras tcp s11n) + +(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest + directory-utils posix-extras matchable) + +(use spiffy uri-common intarweb http-client spiffy-request-vars) + +(declare (unit server)) + +(declare (uses common)) +(declare (uses db)) +(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. +(declare (uses http-transport)) +(declare (uses launch)) + +(declare (uses commonmod)) +(import commonmod) + +(include "common_records.scm") +(include "db_records.scm") + ADDED attic/subrun.scm Index: attic/subrun.scm ================================================================== --- /dev/null +++ attic/subrun.scm @@ -0,0 +1,44 @@ + +;; 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 . + +;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') + +(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) + posix-extras directory-utils pathname-expand typed-records format + call-with-environment-variables) +(declare (unit subrun)) +;;(declare (uses runs)) +(declare (uses db)) +(declare (uses common)) +(declare (uses commonmod)) +(import commonmod) + +;;(declare (uses items)) +;;(declare (uses runconfig)) +;;(declare (uses tests)) +;;(declare (uses server)) +(declare (uses mt)) +;;(declare (uses archive)) +;; (declare (uses filedb)) + +;(include "common_records.scm") +;;(include "key_records.scm") +(include "db_records.scm") ;; provides db:test-get-id +;;(include "run_records.scm") +;;(include "test_records.scm") + ADDED attic/tasks.scm Index: attic/tasks.scm ================================================================== --- /dev/null +++ attic/tasks.scm @@ -0,0 +1,36 @@ +;; 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 format) +(import (prefix sqlite3 sqlite3:)) + +(declare (unit tasks)) +(declare (uses db)) +(declare (uses rmt)) +(declare (uses common)) +(declare (uses pgdb)) + +;; (import pgdb) ;; pgdb is a module +(declare (uses commonmod)) +(import commonmod) + +(include "task_records.scm") +(include "db_records.scm") + ADDED attic/tdb.scm Index: attic/tdb.scm ================================================================== --- /dev/null +++ attic/tdb.scm @@ -0,0 +1,44 @@ +;;====================================================================== +;; 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 . +;; +;;====================================================================== + +;;====================================================================== +;; Database access +;;====================================================================== + +(require-extension (srfi 18) extras tcp) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) +(import (prefix sqlite3 sqlite3:)) +(import (prefix base64 base64:)) + +(declare (unit tdb)) +(declare (uses common)) +(declare (uses keys)) +(declare (uses ods)) +(declare (uses client)) +(declare (uses mt)) +(declare (uses db)) + +(declare (uses commonmod)) +(import commonmod) + +(include "common_records.scm") +(include "db_records.scm") +(include "key_records.scm") +(include "run_records.scm") ADDED attic/tests.scm Index: attic/tests.scm ================================================================== --- /dev/null +++ attic/tests.scm @@ -0,0 +1,40 @@ +;;====================================================================== +;; 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:)) +(require-library stml) + +(declare (unit tests)) +(declare (uses lock-queue)) +(declare (uses db)) +(declare (uses tdb)) +(declare (uses common)) +(declare (uses items)) +(declare (uses runconfig)) +(declare (uses server)) + +(declare (uses commonmod)) +(import commonmod) + DELETED cgisetup/models/pgdb.scm Index: cgisetup/models/pgdb.scm ================================================================== --- cgisetup/models/pgdb.scm +++ /dev/null @@ -1,656 +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 pgdb)) -(declare (uses configf)) - -;; 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) - -(use typed-records (prefix dbi dbi:)) - -;; 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 client.scm Index: client.scm ================================================================== --- client.scm +++ /dev/null @@ -1,38 +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 . - -;;====================================================================== -;; C L I E N T S -;;====================================================================== - -(use srfi-18 extras tcp s11n srfi-1 posix regex srfi-69 hostinfo md5 - message-digest matchable spiffy uri-common intarweb http-client - spiffy-request-vars uri-common intarweb directory-utils) - -(declare (unit client)) - -(declare (uses common)) -(declare (uses db)) -(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. -(declare (uses commonmod)) -(import commonmod) - - -(include "common_records.scm") -(include "db_records.scm") - DELETED common.scm Index: common.scm ================================================================== --- common.scm +++ /dev/null @@ -1,35 +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 . - -;;====================================================================== - -(use srfi-1 data-structures posix regex-case (prefix base64 base64:) - format dot-locking csv-xml z3 udp ;; sql-de-lite - hostinfo md5 message-digest typed-records directory-utils stack - matchable regex posix (srfi 18) extras ;; tcp - (prefix nanomsg nmsg:) - (prefix sqlite3 sqlite3:) - pkts (prefix dbi dbi:) - ) - -(declare (unit common)) -(declare (uses commonmod)) -(import commonmod) - -(include "common_records.scm") - Index: common_records.scm ================================================================== --- common_records.scm +++ common_records.scm @@ -354,12 +354,12 @@ ;; (exec-fn 'db:log-event (apply conc params)) (apply print params) )))) ;; ) ;; Brandon's debug printer shortcut (indulge me :) -(define *BB-process-starttime* (current-milliseconds)) -(define (BB> . in-args) +;; (define *BB-process-starttime* (current-milliseconds)) +#;(define (BB> . in-args) (let* ((stack (get-call-chain)) (location "??")) (for-each (lambda (frame) (let* ((this-loc (vector-ref frame 0)) @@ -375,20 +375,20 @@ (list 0 *default-log-port* (conc color-on location "@"(/ (- (current-milliseconds) *BB-process-starttime*) 1000) color-off " ") ) in-args))) (apply debug:print dp-args)))) -(define *BBpp_custom_expanders_list* (make-hash-table)) +;; (define *BBpp_custom_expanders_list* (make-hash-table)) ;; register hash tables with BBpp. -(hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE: +#;(hash-table-set! *BBpp_custom_expanders_list* HASH_TABLE: (cons hash-table? hash-table->alist)) ;; test name converter -(define (BBpp_custom_converter arg) +#;(define (BBpp_custom_converter arg) (let ((res #f)) (for-each (lambda (custom-type-name) (let* ((custom-type-info (hash-table-ref *BBpp_custom_expanders_list* custom-type-name)) (custom-type-test (car custom-type-info)) @@ -396,11 +396,11 @@ (when (and (not res) (custom-type-test arg)) (set! res (custom-type-converter arg))))) (hash-table-keys *BBpp_custom_expanders_list*)) (if res (BBpp_ res) arg))) -(define (BBpp_ arg) +#;(define (BBpp_ arg) (cond ;;((SOMESTRUCT? arg) (cons SOMESTRUCT: (SOMESTRUCT->alist arg))) ;;((dboard:tabdat? arg) (cons dboard:tabdat: (dboard:tabdat->alist arg))) ((hash-table? arg) (let ((al (hash-table->alist arg))) @@ -409,15 +409,15 @@ ;;((list? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg)))) ((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg)))) (else (BBpp_custom_converter arg)))) ;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp -(define (BBpp arg) +#;(define (BBpp arg) (pp (BBpp_ arg))) ;(use define-macro) -(define-syntax inspect +#;(define-syntax inspect (syntax-rules () [(_ x) ;; (with-output-to-port (current-error-port) (printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x)))) ;; ) DELETED configf.scm Index: configf.scm ================================================================== --- configf.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 . - -;;====================================================================== - -;;====================================================================== -;; Config file handling -;;====================================================================== - -(use regex regex-case) ;; directory-utils) -(declare (unit configf)) -(declare (uses process)) -(declare (uses env)) -(declare (uses keys)) - -(include "common_records.scm") - DELETED db.scm Index: db.scm ================================================================== --- db.scm +++ /dev/null @@ -1,55 +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 . -;; -;;====================================================================== - -;;====================================================================== -;; Database access -;;====================================================================== - -;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc - -(use (srfi 18) extras tcp stack) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64 format dot-locking z3 typed-records matchable) -(import (prefix sqlite3 sqlite3:)) -(import (prefix base64 base64:)) - -(declare (unit db)) -(declare (uses common)) -(declare (uses keys)) -(declare (uses ods)) -(declare (uses client)) -(declare (uses mt)) - -(include "common_records.scm") -(include "db_records.scm") -(include "key_records.scm") -(include "run_records.scm") - -(declare (uses rmtmod)) -(import rmtmod) -(declare (uses dbmod)) -(import dbmod) -(declare (uses commonmod)) -(import commonmod) - -(define *rundb-mutex* (make-mutex)) ;; prevent problems opening/closing rundb's -(define *number-of-writes* 0) -(define *number-non-write-queries* 0) - -(set-fn 'db:setup dbmod#db:setup) DELETED diff-report.scm Index: diff-report.scm ================================================================== --- diff-report.scm +++ /dev/null @@ -1,26 +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) DELETED env.scm Index: env.scm ================================================================== --- env.scm +++ /dev/null @@ -1,24 +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) - DELETED ezsteps.scm Index: ezsteps.scm ================================================================== --- ezsteps.scm +++ /dev/null @@ -1,43 +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) - -(declare (unit ezsteps)) -(declare (uses db)) -(declare (uses common)) -(declare (uses items)) -(declare (uses runconfig)) -(declare (uses commonmod)) -(import commonmod) - -;; (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 - - 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 genexample.scm Index: genexample.scm ================================================================== --- genexample.scm +++ /dev/null @@ -1,23 +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) - DELETED http-transport.scm Index: http-transport.scm ================================================================== --- http-transport.scm +++ /dev/null @@ -1,43 +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) - -(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 portlogger)) -(declare (uses rmt)) - -(declare (uses commonmod)) -(import commonmod) - -(include "common_records.scm") -(include "db_records.scm") -(include "js-path.scm") - -(require-library stml) DELETED items.scm Index: items.scm ================================================================== --- items.scm +++ /dev/null @@ -1,30 +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)) -(declare (uses commonmod)) -(import commonmod) - - -(include "common_records.scm") DELETED keys.scm Index: keys.scm ================================================================== --- keys.scm +++ /dev/null @@ -1,39 +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)) -(declare (uses commonmod)) -(import commonmod) - - -(include "key_records.scm") -(include "common_records.scm") -;;====================================================================== -;; config file related routines -;;====================================================================== - -;; (define keys:config-get-fields common:get-fields) DELETED launch.scm Index: launch.scm ================================================================== --- launch.scm +++ /dev/null @@ -1,42 +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 commonmod)) -(import commonmod) - -(include "common_records.scm") -(include "key_records.scm") -(include "db_records.scm") - DELETED lock-queue.scm Index: lock-queue.scm ================================================================== --- lock-queue.scm +++ /dev/null @@ -1,26 +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)) -(declare (uses commonmod)) -(import commonmod) - DELETED margs.scm Index: margs.scm ================================================================== --- margs.scm +++ /dev/null @@ -1,21 +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)) - DELETED mt.scm Index: mt.scm ================================================================== --- mt.scm +++ /dev/null @@ -1,42 +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)) -(declare (uses commonmod)) -(import commonmod) - - -(include "common_records.scm") -(include "key_records.scm") -(include "db_records.scm") -(include "run_records.scm") -(include "test_records.scm") - DELETED ods.scm Index: ods.scm ================================================================== --- ods.scm +++ /dev/null @@ -1,25 +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)) -(declare (uses commonmod)) -(import commonmod) - - DELETED portlogger.scm Index: portlogger.scm ================================================================== --- portlogger.scm +++ /dev/null @@ -1,28 +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 . -;; - -(require-extension (srfi 18) extras tcp s11n) - -(use sqlite3 srfi-1 posix srfi-69 hostinfo dot-locking z3) -(import (prefix sqlite3 sqlite3:)) - -(declare (unit portlogger)) -(declare (uses db)) - -;; lsof -i DELETED process.scm Index: process.scm ================================================================== --- process.scm +++ /dev/null @@ -1,27 +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 . - -;;====================================================================== - -;;====================================================================== -;; Process convience utils -;;====================================================================== - -(use regex directory-utils) -(declare (unit process)) - DELETED rmt.scm Index: rmt.scm ================================================================== --- rmt.scm +++ /dev/null @@ -1,44 +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 format typed-records) ;; RADT => purpose of json format?? - -(declare (unit rmt)) -(declare (uses api)) -(declare (uses http-transport)) -(include "common_records.scm") - -(declare (uses rmtmod)) -(import rmtmod) -(declare (uses commonmod)) -(import commonmod) - -(set-fn 'server:expiration-timeout server:expiration-timeout) -(set-fn 'common:get-homehost common:get-homehost) -(set-fn 'server:check-if-running server:check-if-running) -(set-fn 'api:execute-requests api:execute-requests) -(set-fn 'http-transport:close-connections http-transport:close-connections ) -(set-fn 'http-transport:client-api-send-receive http-transport:client-api-send-receive) -(set-fn 'server:kind-run server:kind-run) -(set-fn 'server:start-and-wait server:start-and-wait) -(set-fn 'server:check-if-running server:check-if-running) -(set-fn 'server:ping server:ping ) -(set-fn 'common:force-server? common:force-server? ) - DELETED runconfig.scm Index: runconfig.scm ================================================================== --- runconfig.scm +++ /dev/null @@ -1,43 +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 . - -;;====================================================================== -;; read a config file, loading only the section pertinent -;; to this run field1val/field2val/field3val ... -;;====================================================================== - -(use format directory-utils) - -(declare (unit runconfig)) -(declare (uses common)) - -(include "common_records.scm") - - -#| - (if (null? target-strs) - '() - (let loop ((hed (car target-strs)) - (tal (cdr target-strs)) - (res '())) - ;; first break all parts into individual target patterns - (if (string-index hed " ") ;; this is a multi-target target - (let ((newres (append (string-split hed " ") res))) - (runconfig:expand-target newres)) - (if (string-index hed ",") ;; this is a multi-target where one or more parts are comma separated - -|# DELETED runs.scm Index: runs.scm ================================================================== --- runs.scm +++ /dev/null @@ -1,42 +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 . - -;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') - -(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) - posix-extras directory-utils pathname-expand typed-records format) - -(declare (unit runs)) -(declare (uses db)) -(declare (uses common)) -(declare (uses items)) -(declare (uses runconfig)) -(declare (uses tests)) -(declare (uses server)) -(declare (uses mt)) -(declare (uses archive)) -;; (declare (uses filedb)) - -(declare (uses commonmod)) -(import commonmod) - -(include "common_records.scm") -(include "key_records.scm") -(include "db_records.scm") -(include "run_records.scm") -(include "test_records.scm") - DELETED sdb.scm Index: sdb.scm ================================================================== --- sdb.scm +++ /dev/null @@ -1,32 +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 . - -;;====================================================================== - -;;====================================================================== -;; Simple persistant strings lookup table. Keep out of the main db -;; so writes/reads don't slow down central access. -;;====================================================================== - -(require-extension (srfi 18) extras) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) -(import (prefix sqlite3 sqlite3:)) -(import (prefix base64 base64:)) - -(declare (unit sdb)) - Index: server-inc.scm ================================================================== --- server-inc.scm +++ server-inc.scm @@ -283,11 +283,11 @@ servr)) (if (and host port) (conc host ":" port) #f))) -(define (server:get-client-signature) ;; BB> why is this proc named "get-"? it returns nothing -- set! has not return value. +(define (server:get-client-signature) (if *my-client-signature* *my-client-signature* (let ((sig (server:mk-signature))) (set! *my-client-signature* sig) *my-client-signature*))) @@ -502,11 +502,11 @@ (calculate-off-time (lambda (work-duration duty-cycle) (* (/ (- 1 duty-cycle) duty-cycle) last-sync-seconds))) (off-time min-intersync-delay) ;; adjusted in closure below. (do-a-sync (lambda () - (BB> "Start do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync) + #;(BB> "Start do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync) (let* ((finalres (let retry-loop ((num-tries 0)) (if (common:simple-file-lock lockfile) (begin (cond @@ -548,12 +548,12 @@ (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Sync failed. See log at "sync-log".fail") (if (file-exists? (conc mtdbfile ".backup")) (system (conc "/bin/cp "mtdbfile ".backup " mtdbfile))) #f)))) (common:simple-file-release-lock lockfile) - (BB> "released lockfile: " lockfile) - (when (common:file-exists? lockfile) + #;(BB> "released lockfile: " lockfile) + #;(when (common:file-exists? lockfile) (BB> "DID NOT ACTUALLY RELEASE LOCKFILE")) res2) ;; end let );; end begin ;; else (cond @@ -566,11 +566,11 @@ (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; not syncing.") 'parallel-sync-in-progress)) ) ;; end if got lockfile ) )) - (BB> "End do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync" and result="finalres) + #;(BB> "End do-a-sync with fork-to-background="fork-to-background" persist-until-sync="persist-until-sync" and result="finalres) finalres) ) ;; end lambda )) do-a-sync)) DELETED server.scm Index: server.scm ================================================================== --- server.scm +++ /dev/null @@ -1,40 +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 . -;; - -(require-extension (srfi 18) extras tcp s11n) - -(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest - directory-utils posix-extras matchable) - -(use spiffy uri-common intarweb http-client spiffy-request-vars) - -(declare (unit server)) - -(declare (uses common)) -(declare (uses db)) -(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. -(declare (uses http-transport)) -(declare (uses launch)) - -(declare (uses commonmod)) -(import commonmod) - -(include "common_records.scm") -(include "db_records.scm") - DELETED subrun.scm Index: subrun.scm ================================================================== --- subrun.scm +++ /dev/null @@ -1,44 +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 . - -;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') - -(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) - posix-extras directory-utils pathname-expand typed-records format - call-with-environment-variables) -(declare (unit subrun)) -;;(declare (uses runs)) -(declare (uses db)) -(declare (uses common)) -(declare (uses commonmod)) -(import commonmod) - -;;(declare (uses items)) -;;(declare (uses runconfig)) -;;(declare (uses tests)) -;;(declare (uses server)) -(declare (uses mt)) -;;(declare (uses archive)) -;; (declare (uses filedb)) - -;(include "common_records.scm") -;;(include "key_records.scm") -(include "db_records.scm") ;; provides db:test-get-id -;;(include "run_records.scm") -;;(include "test_records.scm") - DELETED tasks.scm Index: tasks.scm ================================================================== --- tasks.scm +++ /dev/null @@ -1,36 +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 format) -(import (prefix sqlite3 sqlite3:)) - -(declare (unit tasks)) -(declare (uses db)) -(declare (uses rmt)) -(declare (uses common)) -(declare (uses pgdb)) - -;; (import pgdb) ;; pgdb is a module -(declare (uses commonmod)) -(import commonmod) - -(include "task_records.scm") -(include "db_records.scm") - DELETED tdb.scm Index: tdb.scm ================================================================== --- tdb.scm +++ /dev/null @@ -1,44 +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 . -;; -;;====================================================================== - -;;====================================================================== -;; Database access -;;====================================================================== - -(require-extension (srfi 18) extras tcp) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64) -(import (prefix sqlite3 sqlite3:)) -(import (prefix base64 base64:)) - -(declare (unit tdb)) -(declare (uses common)) -(declare (uses keys)) -(declare (uses ods)) -(declare (uses client)) -(declare (uses mt)) -(declare (uses db)) - -(declare (uses commonmod)) -(import commonmod) - -(include "common_records.scm") -(include "db_records.scm") -(include "key_records.scm") -(include "run_records.scm") DELETED tests.scm Index: tests.scm ================================================================== --- tests.scm +++ /dev/null @@ -1,40 +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:)) -(require-library stml) - -(declare (unit tests)) -(declare (uses lock-queue)) -(declare (uses db)) -(declare (uses tdb)) -(declare (uses common)) -(declare (uses items)) -(declare (uses runconfig)) -(declare (uses server)) - -(declare (uses commonmod)) -(import commonmod) -