Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -23,11 +23,11 @@ INSTALL=install SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm \ server.scm configf.scm db.scm keys.scm margs.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ tdb.scm mt.scm \ - ezsteps.scm lock-queue.scm rmt.scm api.scm \ + ezsteps.scm rmt.scm api.scm \ subrun.scm archive.scm env.scm \ diff-report.scm cgisetup/models/pgdb.scm # module source files MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm \ @@ -130,11 +130,10 @@ db.o \ env.o \ items.o \ keys.o \ launch.o \ - lock-queue.o \ margs.o \ mt.o \ ods.o \ process.o \ rmt.o \ @@ -500,28 +499,29 @@ fi if csi -ne '(import postgresql)'&> /dev/null;then \ echo "(import postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\ fi -portlogger-example : portlogger-example.scm api.o archive.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o server.o synchash.o tasks.o tdb.o tests.o tree.o - csc $(CSCOPTS) portlogger-example.scm api.o archive.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o server.o synchash.o tasks.o tdb.o tests.o tree.o +# portlogger-example : portlogger-example.scm api.o archive.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o server.o synchash.o tasks.o tdb.o tests.o tree.o +# csc $(CSCOPTS) portlogger-example.scm api.o archive.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o genexample.o gutils.o items.o keys.o launch.o lock-queue.o margs.o mt.o ods.o portlogger.o process.o rmt.o runconfig.o runs.o server.o sync-hash.o tasks.o tdb.o tests.o tree.o + +unitdeps.dot : *scm ./utils/plot-uses Makefile + ./utils/plot-uses todot commonmod.import,mtargs.import,mtargs,debugprint *.scm > unitdeps.dot + +unitdeps.pdf : unitdeps.dot + dot unitdeps.dot -Tpdf -o unitdeps.pdf + +./utils/plot-uses : utils/plot-uses.scm + csc utils/plot-uses.scm # create a pdf dot graphviz diagram from notations in rmt.scm rmt.pdf : rmt.scm grep ';;DOT' rmt.scm | sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf buildmanual: cd docs/manual && make -wikipage=plan -editwiki: - cd docs/manual && ../../utils/editwiki $(wikipage) - -viewmanual: - arora docs/manual/megatest_manual.html - targets: @grep : Makefile | perl -ne '/^([A-Za-z0-9_-]+):/ && print "$$1\n"' - unit : cd tests;make unit Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -17,23 +17,20 @@ ;; along with Megatest. If not, see . ;; ;;====================================================================== (declare (unit api)) -(declare (uses rmt)) (declare (uses db)) (declare (uses debugprint)) (declare (uses dbmod)) (declare (uses dbfile)) (declare (uses tasks)) -(declare (uses rmtmod)) (declare (uses tcp-transportmod)) (import dbmod) (import dbfile) (import debugprint) -(import rmtmod) (import tcp-transportmod) (use srfi-69 posix matchable Index: apimod.scm ================================================================== --- apimod.scm +++ apimod.scm @@ -18,17 +18,15 @@ ;;====================================================================== (declare (unit apimod)) (declare (uses commonmod)) -(declare (uses ulex)) (module apimod * (import scheme chicken data-structures extras) (import (prefix sqlite3 sqlite3:) posix typed-records srfi-18) (import commonmod) -(import (prefix ulex ulex:)) ) ADDED attic/index-tree.scm Index: attic/index-tree.scm ================================================================== --- /dev/null +++ attic/index-tree.scm @@ -0,0 +1,61 @@ +;;====================================================================== +;; Copyright 2006-2013, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . +;; +;;====================================================================== + +;;====================================================================== +;; Tests +;;====================================================================== + +(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils) +(import (prefix sqlite3 sqlite3:)) + +(declare (unit tests)) +(declare (uses lock-queue)) +(declare (uses db)) +(declare (uses common)) +(declare (uses items)) +(declare (uses runconfig)) +(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") + +;; Populate the links tree with index.html files +;; +;; - start from most recent tests and work towards oldest -OR- +;; start from deepest hierarchy and work way up +;; - look up tests in megatest.db +;; - cross-reference the tests to stats.db +;; - if newer than event_time in stats.db or not registered in stats.db regenerate +;; - run du and store in stats.db +;; - when all tests at that level done generate next level up index.html +;; +;; include in rollup html index.html: +;; sum of du +;; counts of PASS, FAIL, RUNNING, REMOTEHOSTSTART, LAUNCHED, CHECK etc. +;; overall status +;; +;; include in test specific index.html: +;; host, uname, cpu graph, disk avail graph, steps, data +;; meta data, state, status, du +;; ADDED attic/lock-queue.scm Index: attic/lock-queue.scm ================================================================== --- /dev/null +++ attic/lock-queue.scm @@ -0,0 +1,258 @@ +;; 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 debugprint)) +(declare (uses tasks)) +(declare (uses commonmod)) + +(import commonmod + debugprint) + +;;====================================================================== +;; attempt to prevent overlapping updates of rollup files by queueing +;; update requests in an sqlite db +;;====================================================================== + +;;====================================================================== +;; db record, +;;====================================================================== + +(define (make-lock-queue:db-dat)(make-vector 3)) +(define-inline (lock-queue:db-dat-get-db vec) (vector-ref vec 0)) +(define-inline (lock-queue:db-dat-get-path vec) (vector-ref vec 1)) +(define-inline (lock-queue:db-dat-set-db! vec val)(vector-set! vec 0 val)) +(define-inline (lock-queue:db-dat-set-path! vec val)(vector-set! vec 1 val)) + +(define (lock-queue:delete-lock-db dbdat) + (let ((fname (lock-queue:db-dat-get-path dbdat))) + (system (conc "rm -f " fname "*")))) + +(define (lock-queue:open-db fname #!key (count 10)) + (let* ((actualfname (conc fname ".lockdb")) + (dbexists (common:file-exists? actualfname)) + (db (sqlite3:open-database actualfname)) + (handler (make-busy-timeout 136000))) + (if dbexists + (vector db actualfname) + (begin + (handle-exceptions + exn + (begin + (thread-sleep! 10) + (if (> count 0) + (lock-queue:open-db fname count: (- count 1)) + (vector db actualfname))) + (sqlite3:with-transaction + db + (lambda () + (sqlite3:execute + db + "CREATE TABLE IF NOT EXISTS queue ( + id INTEGER PRIMARY KEY, + test_id INTEGER, + start_time INTEGER, + state TEXT, + CONSTRAINT queue_constraint UNIQUE (test_id));") + (sqlite3:execute + db + "CREATE TABLE IF NOT EXISTS runlocks ( + id INTEGER PRIMARY KEY, + test_id INTEGER, + run_lock TEXT, + CONSTRAINT runlock_constraint UNIQUE (run_lock));")))))) + (sqlite3:set-busy-handler! db handler) + (vector db actualfname))) + +(define (lock-queue:set-state dbdat test-id newstate #!key (remtries 10)) + (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200) + (handle-exceptions + exn + (if (> remtries 0) + (begin + (debug:print 0 *default-log-port* "WARNING: exception on lock-queue:set-state. Trying again in 30 seconds.") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (thread-sleep! 30) + (lock-queue:set-state dbdat test-id newstate remtries: (- remtries 1))) + (begin + (debug:print-error 0 *default-log-port* " Failed to set lock state for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.") + #f)) + (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "UPDATE queue SET state=? WHERE test_id=?;" + newstate + test-id))) + +(define (lock-queue:any-younger? dbdat mystart test-id #!key (remtries 10)) + ;; no need to wait on journal on read only queries + ;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200) + (handle-exceptions + exn + (if (> remtries 0) + (begin + (debug:print 0 *default-log-port* "WARNING: exception on lock-queue:any-younger. Removing lockdb and trying again in 5 seconds.") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (thread-sleep! 5) + (lock-queue:delete-lock-db dbdat) + (lock-queue:any-younger? dbdat mystart test-id remtries: (- remtries 1))) + (begin + (debug:print-error 0 *default-log-port* " Failed to find younger locks for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.") + #f)) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (tid) + ;; Actually this should not be needed as mystart cannot be simultaneously less than and test-id same as + (if (not (equal? tid test-id)) + (set! res tid))) + (lock-queue:db-dat-get-db dbdat) + "SELECT test_id FROM queue WHERE start_time > ?;" mystart) + res))) + +(define (lock-queue:get-lock dbdat test-id #!key (count 10)(waiting-msg #f)) + (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 remove: #t waiting-msg: "lock-queue:get-lock, waiting on journal") + (let* ((res #f) + (db (lock-queue:db-dat-get-db dbdat)) + (lckqry (sqlite3:prepare db "SELECT test_id,run_lock FROM runlocks WHERE run_lock='locked';")) + (mklckqry (sqlite3:prepare db "INSERT INTO runlocks (test_id,run_lock) VALUES (?,'locked');"))) + (let ((result + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "WARNING: failed to get queue lock. Removing lock db and returning fail") ;; Will try again in a few seconds") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (thread-sleep! 10) + ;; (if (> count 0) + ;; #f ;; (lock-queue:get-lock dbdat test-id count: (- count 1)) - give up on retries + ;; (begin ;; never recovered, remote the lock file and return #f, no lock obtained + (lock-queue:delete-lock-db dbdat) + #f) + (sqlite3:with-transaction + db + (lambda () + (sqlite3:for-each-row (lambda (tid lockstate) + (set! res (list tid lockstate))) + lckqry) + (if res + (if (equal? (car res) test-id) + #t ;; already have the lock + #f) + (begin + (sqlite3:execute mklckqry test-id) + ;; if no error handled then return #t for got the lock + #t))))))) + (sqlite3:finalize! lckqry) + (sqlite3:finalize! mklckqry) + result))) + +(define (lock-queue:release-lock fname test-id #!key (count 10)) + (let* ((dbdat (lock-queue:open-db fname))) + (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:release-lock; waiting on journal") + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "WARNING: Failed to release queue lock. Will try again in few seconds") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (thread-sleep! (/ count 10)) + (if (> count 0) + (begin + (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat)) + (lock-queue:release-lock fname test-id count: (- count 1))) + (let ((journal (conc fname "-journal"))) + ;; If we've tried ten times and failed there is a serious problem + ;; try to remove the lock db and allow it to be recreated + (handle-exceptions + exn + #f + (if (common:file-exists? journal)(delete-file journal)) + (if (common:file-exists? fname) (delete-file fname)) + #f)))) + (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE test_id=?;" test-id) + (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat))))) + +(define (lock-queue:steal-lock dbdat test-id #!key (count 10)) + (debug:print-info 0 *default-log-port* "Attempting to steal lock at " (lock-queue:db-dat-get-path dbdat)) + (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:steal-lock; waiting on journal") + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "WARNING: Failed to steal queue lock. Will try again in few seconds") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (thread-sleep! 10) + (if (> count 0) + (lock-queue:steal-lock dbdat test-id count: (- count 1)) + #f)) + (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE run_lock='locked';")) + (lock-queue:get-lock dbdat test-it)) + +;; returns #f if ok to skip the task +;; returns #t if ok to proceed with task +;; otherwise waits +;; +(define (lock-queue:wait-turn fname test-id #!key (count 10)(waiting-msg #f)) + (let* ((dbdat (lock-queue:open-db fname)) + (mystart (current-seconds)) + (db (lock-queue:db-dat-get-db dbdat))) + ;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file") + (handle-exceptions + exn + (begin + (debug:print 0 *default-log-port* "WARNING: Failed to find out if it is ok to skip the wait queue. Will try again in few seconds") + (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) + (print-call-chain (current-error-port)) + (thread-sleep! 10) + (if (> count 0) + (begin + (sqlite3:finalize! db) + (lock-queue:wait-turn fname test-id count: (- count 1))) + (begin + (debug:print 0 *default-log-port* "Giving up calls to lock-queue:wait-turn for test-id " test-id " at path " fname ", printing call chain") + (print-call-chain (current-error-port)) + #f))) + ;; wait 10 seconds and then check to see if someone is already updating the html + (thread-sleep! 10) + (if (not (lock-queue:any-younger? dbdat mystart test-id)) ;; no processing in flight, must try to start processing + (begin + (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file") + (sqlite3:execute + db + "INSERT OR REPLACE INTO queue (test_id,start_time,state) VALUES (?,?,'waiting');" + test-id mystart) + ;; (thread-sleep! 1) ;; give other tests a chance to register + (let ((result + (let loop ((younger-waiting (lock-queue:any-younger? dbdat mystart test-id))) + (if younger-waiting + (begin + ;; no need for us to wait. mark in the lock queue db as skipping + ;; no point in marking anything in the queue - simply never register this + ;; test as it is *covered* by a previously started update to the html file + ;; (lock-queue:set-state dbdat test-id "skipping") + #f) ;; let the calling process know that nothing needs to be done + (if (lock-queue:get-lock dbdat test-id) + #t + (if (> (- (current-seconds) mystart) 36000) ;; waited too long, steal the lock + (lock-queue:steal-lock dbdat test-id) + (begin + (thread-sleep! 1) + (loop (lock-queue:any-younger? dbdat mystart test-id))))))))) + (sqlite3:finalize! db) + result)))))) + + +;; (use trace) +;; (trace lock-queue:get-lock lock-queue:release-lock lock-queue:wait-turn lock-queue:any-younger? lock-queue:set-state) Index: commonmod.scm ================================================================== --- commonmod.scm +++ commonmod.scm @@ -93,10 +93,16 @@ ;;====================================================================== (include "megatest-version.scm") (include "megatest-fossil-hash.scm") +;; http - use the old http + in /tmp db +;; tcp - use tcp transport with inmem db +;; nfs - use direct to disk access (read-only) +;; +(define rmt:transport-mode (make-parameter 'tcp)) + (define (get-full-version) (conc megatest-version "-" megatest-fossil-hash)) (define (version-signature) (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) DELETED index-tree.scm Index: index-tree.scm ================================================================== --- index-tree.scm +++ /dev/null @@ -1,61 +0,0 @@ -;;====================================================================== -;; Copyright 2006-2013, Matthew Welland. -;; -;; This file is part of Megatest. -;; -;; Megatest is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. -;; -;; Megatest is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with Megatest. If not, see . -;; -;;====================================================================== - -;;====================================================================== -;; Tests -;;====================================================================== - -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils) -(import (prefix sqlite3 sqlite3:)) - -(declare (unit tests)) -(declare (uses lock-queue)) -(declare (uses db)) -(declare (uses common)) -(declare (uses items)) -(declare (uses runconfig)) -(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") - -;; Populate the links tree with index.html files -;; -;; - start from most recent tests and work towards oldest -OR- -;; start from deepest hierarchy and work way up -;; - look up tests in megatest.db -;; - cross-reference the tests to stats.db -;; - if newer than event_time in stats.db or not registered in stats.db regenerate -;; - run du and store in stats.db -;; - when all tests at that level done generate next level up index.html -;; -;; include in rollup html index.html: -;; sum of du -;; counts of PASS, FAIL, RUNNING, REMOTEHOSTSTART, LAUNCHED, CHECK etc. -;; overall status -;; -;; include in test specific index.html: -;; host, uname, cpu graph, disk avail graph, steps, data -;; meta data, state, status, du -;; DELETED lock-queue.scm Index: lock-queue.scm ================================================================== --- lock-queue.scm +++ /dev/null @@ -1,258 +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 debugprint)) -(declare (uses tasks)) -(declare (uses commonmod)) - -(import commonmod - debugprint) - -;;====================================================================== -;; attempt to prevent overlapping updates of rollup files by queueing -;; update requests in an sqlite db -;;====================================================================== - -;;====================================================================== -;; db record, -;;====================================================================== - -(define (make-lock-queue:db-dat)(make-vector 3)) -(define-inline (lock-queue:db-dat-get-db vec) (vector-ref vec 0)) -(define-inline (lock-queue:db-dat-get-path vec) (vector-ref vec 1)) -(define-inline (lock-queue:db-dat-set-db! vec val)(vector-set! vec 0 val)) -(define-inline (lock-queue:db-dat-set-path! vec val)(vector-set! vec 1 val)) - -(define (lock-queue:delete-lock-db dbdat) - (let ((fname (lock-queue:db-dat-get-path dbdat))) - (system (conc "rm -f " fname "*")))) - -(define (lock-queue:open-db fname #!key (count 10)) - (let* ((actualfname (conc fname ".lockdb")) - (dbexists (common:file-exists? actualfname)) - (db (sqlite3:open-database actualfname)) - (handler (make-busy-timeout 136000))) - (if dbexists - (vector db actualfname) - (begin - (handle-exceptions - exn - (begin - (thread-sleep! 10) - (if (> count 0) - (lock-queue:open-db fname count: (- count 1)) - (vector db actualfname))) - (sqlite3:with-transaction - db - (lambda () - (sqlite3:execute - db - "CREATE TABLE IF NOT EXISTS queue ( - id INTEGER PRIMARY KEY, - test_id INTEGER, - start_time INTEGER, - state TEXT, - CONSTRAINT queue_constraint UNIQUE (test_id));") - (sqlite3:execute - db - "CREATE TABLE IF NOT EXISTS runlocks ( - id INTEGER PRIMARY KEY, - test_id INTEGER, - run_lock TEXT, - CONSTRAINT runlock_constraint UNIQUE (run_lock));")))))) - (sqlite3:set-busy-handler! db handler) - (vector db actualfname))) - -(define (lock-queue:set-state dbdat test-id newstate #!key (remtries 10)) - (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200) - (handle-exceptions - exn - (if (> remtries 0) - (begin - (debug:print 0 *default-log-port* "WARNING: exception on lock-queue:set-state. Trying again in 30 seconds.") - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (thread-sleep! 30) - (lock-queue:set-state dbdat test-id newstate remtries: (- remtries 1))) - (begin - (debug:print-error 0 *default-log-port* " Failed to set lock state for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.") - #f)) - (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "UPDATE queue SET state=? WHERE test_id=?;" - newstate - test-id))) - -(define (lock-queue:any-younger? dbdat mystart test-id #!key (remtries 10)) - ;; no need to wait on journal on read only queries - ;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200) - (handle-exceptions - exn - (if (> remtries 0) - (begin - (debug:print 0 *default-log-port* "WARNING: exception on lock-queue:any-younger. Removing lockdb and trying again in 5 seconds.") - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (thread-sleep! 5) - (lock-queue:delete-lock-db dbdat) - (lock-queue:any-younger? dbdat mystart test-id remtries: (- remtries 1))) - (begin - (debug:print-error 0 *default-log-port* " Failed to find younger locks for test with id " test-id ", error: " ((condition-property-accessor 'exn 'message) exn) ", giving up.") - #f)) - (let ((res #f)) - (sqlite3:for-each-row - (lambda (tid) - ;; Actually this should not be needed as mystart cannot be simultaneously less than and test-id same as - (if (not (equal? tid test-id)) - (set! res tid))) - (lock-queue:db-dat-get-db dbdat) - "SELECT test_id FROM queue WHERE start_time > ?;" mystart) - res))) - -(define (lock-queue:get-lock dbdat test-id #!key (count 10)(waiting-msg #f)) - (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 remove: #t waiting-msg: "lock-queue:get-lock, waiting on journal") - (let* ((res #f) - (db (lock-queue:db-dat-get-db dbdat)) - (lckqry (sqlite3:prepare db "SELECT test_id,run_lock FROM runlocks WHERE run_lock='locked';")) - (mklckqry (sqlite3:prepare db "INSERT INTO runlocks (test_id,run_lock) VALUES (?,'locked');"))) - (let ((result - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "WARNING: failed to get queue lock. Removing lock db and returning fail") ;; Will try again in a few seconds") - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (thread-sleep! 10) - ;; (if (> count 0) - ;; #f ;; (lock-queue:get-lock dbdat test-id count: (- count 1)) - give up on retries - ;; (begin ;; never recovered, remote the lock file and return #f, no lock obtained - (lock-queue:delete-lock-db dbdat) - #f) - (sqlite3:with-transaction - db - (lambda () - (sqlite3:for-each-row (lambda (tid lockstate) - (set! res (list tid lockstate))) - lckqry) - (if res - (if (equal? (car res) test-id) - #t ;; already have the lock - #f) - (begin - (sqlite3:execute mklckqry test-id) - ;; if no error handled then return #t for got the lock - #t))))))) - (sqlite3:finalize! lckqry) - (sqlite3:finalize! mklckqry) - result))) - -(define (lock-queue:release-lock fname test-id #!key (count 10)) - (let* ((dbdat (lock-queue:open-db fname))) - (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:release-lock; waiting on journal") - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "WARNING: Failed to release queue lock. Will try again in few seconds") - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (thread-sleep! (/ count 10)) - (if (> count 0) - (begin - (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat)) - (lock-queue:release-lock fname test-id count: (- count 1))) - (let ((journal (conc fname "-journal"))) - ;; If we've tried ten times and failed there is a serious problem - ;; try to remove the lock db and allow it to be recreated - (handle-exceptions - exn - #f - (if (common:file-exists? journal)(delete-file journal)) - (if (common:file-exists? fname) (delete-file fname)) - #f)))) - (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE test_id=?;" test-id) - (sqlite3:finalize! (lock-queue:db-dat-get-db dbdat))))) - -(define (lock-queue:steal-lock dbdat test-id #!key (count 10)) - (debug:print-info 0 *default-log-port* "Attempting to steal lock at " (lock-queue:db-dat-get-path dbdat)) - (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 "lock-queue:steal-lock; waiting on journal") - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "WARNING: Failed to steal queue lock. Will try again in few seconds") - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (thread-sleep! 10) - (if (> count 0) - (lock-queue:steal-lock dbdat test-id count: (- count 1)) - #f)) - (sqlite3:execute (lock-queue:db-dat-get-db dbdat) "DELETE FROM runlocks WHERE run_lock='locked';")) - (lock-queue:get-lock dbdat test-it)) - -;; returns #f if ok to skip the task -;; returns #t if ok to proceed with task -;; otherwise waits -;; -(define (lock-queue:wait-turn fname test-id #!key (count 10)(waiting-msg #f)) - (let* ((dbdat (lock-queue:open-db fname)) - (mystart (current-seconds)) - (db (lock-queue:db-dat-get-db dbdat))) - ;; (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file") - (handle-exceptions - exn - (begin - (debug:print 0 *default-log-port* "WARNING: Failed to find out if it is ok to skip the wait queue. Will try again in few seconds") - (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) - (print-call-chain (current-error-port)) - (thread-sleep! 10) - (if (> count 0) - (begin - (sqlite3:finalize! db) - (lock-queue:wait-turn fname test-id count: (- count 1))) - (begin - (debug:print 0 *default-log-port* "Giving up calls to lock-queue:wait-turn for test-id " test-id " at path " fname ", printing call chain") - (print-call-chain (current-error-port)) - #f))) - ;; wait 10 seconds and then check to see if someone is already updating the html - (thread-sleep! 10) - (if (not (lock-queue:any-younger? dbdat mystart test-id)) ;; no processing in flight, must try to start processing - (begin - (tasks:wait-on-journal (lock-queue:db-dat-get-path dbdat) 1200 waiting-msg: "lock-queue:wait-turn; waiting on journal file") - (sqlite3:execute - db - "INSERT OR REPLACE INTO queue (test_id,start_time,state) VALUES (?,?,'waiting');" - test-id mystart) - ;; (thread-sleep! 1) ;; give other tests a chance to register - (let ((result - (let loop ((younger-waiting (lock-queue:any-younger? dbdat mystart test-id))) - (if younger-waiting - (begin - ;; no need for us to wait. mark in the lock queue db as skipping - ;; no point in marking anything in the queue - simply never register this - ;; test as it is *covered* by a previously started update to the html file - ;; (lock-queue:set-state dbdat test-id "skipping") - #f) ;; let the calling process know that nothing needs to be done - (if (lock-queue:get-lock dbdat test-id) - #t - (if (> (- (current-seconds) mystart) 36000) ;; waited too long, steal the lock - (lock-queue:steal-lock dbdat test-id) - (begin - (thread-sleep! 1) - (loop (lock-queue:any-younger? dbdat mystart test-id))))))))) - (sqlite3:finalize! db) - result)))))) - - -;; (use trace) -;; (trace lock-queue:get-lock lock-queue:release-lock lock-queue:wait-turn lock-queue:any-younger? lock-queue:set-state) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -38,15 +38,10 @@ ;; dbmemmod dbfile dbmod tcp-transportmod) -;; http - use the old http + in /tmp db -;; tcp - use tcp transport with inmem db -;; nfs - use direct to disk access (read-only) -;; -(define rmt:transport-mode (make-parameter 'tcp)) ;; ;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!! ;; ;; generate entries for ~/.megatestrc with the following Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -21,22 +21,18 @@ ;;====================================================================== ;; Tests ;;====================================================================== (declare (unit tests)) -(declare (uses lock-queue)) (declare (uses db)) (declare (uses tdb)) (declare (uses debugprint)) (declare (uses common)) (declare (uses commonmod)) -;; (declare (uses dcommon)) ;; needed for the steps processing (declare (uses items)) (declare (uses runconfig)) -;; (declare (uses sdb)) (declare (uses server)) -;;(declare (uses stml2)) (declare (uses mtargs)) (declare (uses rmtmod)) (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils) (import (prefix sqlite3 sqlite3:)) DELETED ulex.scm Index: ulex.scm ================================================================== --- ulex.scm +++ /dev/null @@ -1,24 +0,0 @@ -;;====================================================================== -;; Copyright 2019, Matthew Welland. -;; -;; This file is part of Megatest. -;; -;; Megatest is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. -;; -;; Megatest is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with Megatest. If not, see . - -;;====================================================================== - -(declare (unit ulex)) -(declare (uses pkts)) - -(include "ulex/ulex.scm") ADDED utils/plot-uses.scm Index: utils/plot-uses.scm ================================================================== --- /dev/null +++ utils/plot-uses.scm @@ -0,0 +1,147 @@ +#!/mfs/pkgs/chicken/4.8.0.5/bin/csi -nbq + +;; 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 . +;; + +;; Coming soon (right?) Usage: plot-code file1.scm,file2.scm "fun1,fun2,x*" *.scm > plot.dot +;; Usage: plot-code file1.scm,file2.scm *.scm > plot.dot +;; dot -Tpdf plot.dot > plot.pdf +;; first param is comma separated list of files to include in the map, use - to do all +;; second param is list of regexs for functions to include in the map +;; third param is list of files to scan + +(module plot-uses + * + +(import scheme chicken) + +(use regex srfi-69 srfi-13) +(use matchable data-structures ports extras) + +(define unituses-rx (regexp "^\\(declare \\((unit|uses) ([^\\(\\)]+)\\).*")) + +(define (print-err . data) + (with-output-to-port (current-error-port) + (lambda () + (apply print data)))) + +(define (process-file ignores fname) + (with-input-from-file fname + (lambda () + (let loop ((modname "DUMMYMOD")) + (let* ((inl (read-line))) + (if (eof-object? inl) + #t + (match (string-search unituses-rx inl) + ((_ dtype unitname) + (if (equal? dtype "unit") + (loop unitname) + (begin + (if (equal? dtype "uses") + (if (not (or (member modname '("DUMMYMOD")) + (member modname ignores) + (member unitname ignores))) + (print " \""unitname"\" -> \""modname"\";")) + (print-err "ERROR: bad declare line \""inl"\"")) + (loop modname)))) + (else + (loop modname))))))))) + +(define (main) + (match (command-line-arguments) + (("todot" ignoreunits . files) + (let* ((ignores (string-split ignoreunits ","))) + (print-err "Making graph for files: " (string-intersperse files ", ")) + (print "digraph uses_unit {") + (for-each + (lambda (fname) + (print "// Filename: "fname) + (process-file ignores fname)) + files) + (print "}"))) + (else + (print-err "Usage: plot-uses u1,u2... file1.scm ...") + (print-err " where u1,u2... are units to ignore and file1.scm... are the files to process.")))) + +(main) + +) +;; +;; ;; Gather the usages +;; (print "digraph G {") +;; (define curr-cluster-num 0) +;; (define function-calls '()) +;; +;; (for-each +;; (lambda (fname) +;; (let ((last-func #f)) +;; (print-err "Processing file " fname) +;; (print "subgraph cluster_" curr-cluster-num " {") +;; (set! curr-cluster-num (+ curr-cluster-num 1)) +;; (with-input-from-file fname +;; (lambda () +;; (with-output-to-port (current-error-port) +;; (lambda () +;; (print "Analyzing file " fname))) +;; (print "label=\"" fname "\";") +;; (let loop ((inl (read-line)) +;; (fnname "toplevel") +;; (allcalls '())) +;; (if (eof-object? inl) +;; (begin +;; (set! function-calls (cons (list fnname allcalls) function-calls)) +;; (for-each +;; (lambda (call-name) +;; (hash-table-set! breadcrumbs call-name #t)) +;; allcalls) +;; (print-err "function: " fnname " allcalls: " allcalls)) +;; (let ((match (string-match defn-rx inl))) +;; (if match +;; (let ((func-name (cadr match))) +;; (if last-func +;; (print "\"" func-name "\" -> \"" last-func "\";") +;; (print "\"" func-name "\";")) +;; (set! last-func func-name) +;; (hash-table-set! breadcrumbs func-name #t) +;; (loop (read-line) +;; func-name +;; allcalls)) +;; (let ((calls (look-for-all-calls inl fnname))) +;; (loop (read-line) fnname (append allcalls calls))))))))) +;; (print "}"))) +;; targs) +;; +;; (print-err "breadcrumbs: " (hash-table-keys breadcrumbs)) +;; (print-err "function-calls: " function-calls) +;; +;; (for-each +;; (lambda (function-call) +;; (print-err "function-call: " function-call) +;; (let ((fnname (car function-call)) +;; (calls (cadr function-call))) +;; (for-each +;; (lambda (callname) +;; (print (if (hash-table-ref/default breadcrumbs callname #f) "" "// ") +;; "\"" fnname "\" -> \"" callname "\";")) +;; calls))) +;; function-calls) +;; +;; (print "}") +;; +;; (exit) +;;