Check-in [3cbc9cb854]
Not logged in
Overview
SHA1 Hash:3cbc9cb854fe298dda8320edf5e9f0d62d792fe8
Date: 2011-10-23 06:02:53
User: matt
Comment:Progress on monitor based running
Timelines: family | ancestors | descendants | both | trunk
Downloads: Tarball | ZIP archive
Other Links: files | file ages | manifest
Tags And Properties
Changes

Modified Makefile from [2418e6dec96d4f00] to [d16e947139ad6789].

1 1 2 PREFIX=. 2 PREFIX=. 3 3 4 SRCFILES = common.scm items.scm launch.scm \ 4 SRCFILES = common.scm items.scm launch.scm \ 5 ods.scm runconfig.scm server.scm configf.scm \ 5 ods.scm runconfig.scm server.scm configf.scm \ 6 db.scm keys.scm margs.scm megatest-version.scm \ 6 db.scm keys.scm margs.scm megatest-version.scm \ 7 process.scm runs.scm | 7 process.scm runs.scm tasks.scm 8 8 9 GUISRCF = dashboard.scm dashboard-tests.scm | 9 GUISRCF = dashboard.scm dashboard-tests.scm dashboard-guimonitor.scm 10 10 11 OFILES = $(SRCFILES:%.scm=%.o) 11 OFILES = $(SRCFILES:%.scm=%.o) 12 GOFILES = $(GUISRCF:%.scm=%.o) 12 GOFILES = $(GUISRCF:%.scm=%.o) 13 13 14 HELPERS=$(addprefix $(PREFIX)/bin/,mt_laststep mt_runstep mt_ezstep) 14 HELPERS=$(addprefix $(PREFIX)/bin/,mt_laststep mt_runstep mt_ezstep) 15 15 16 all : megatest dboard 16 all : megatest dboard ................................................................................................................................................................................ 21 dboard : $(OFILES) $(GOFILES) 21 dboard : $(OFILES) $(GOFILES) 22 csc $(OFILES) $(GOFILES) -o dboard 22 csc $(OFILES) $(GOFILES) -o dboard 23 23 24 # Special dependencies for the includes 24 # Special dependencies for the includes 25 db.o launch.o runs.o dashboard-tests.o dashboard.o megatest.o : db_records.scm 25 db.o launch.o runs.o dashboard-tests.o dashboard.o megatest.o : db_records.scm 26 runs.o dashboard.o dashboard-tests.o : run_records.scm 26 runs.o dashboard.o dashboard-tests.o : run_records.scm 27 keys.o db.o runs.o launch.o megatest.o : key_records.scm 27 keys.o db.o runs.o launch.o megatest.o : key_records.scm > 28 tasks.o dashboard-tasks.o : task_records.scm 28 29 29 $(OFILES) $(GOFILES) : common_records.scm 30 $(OFILES) $(GOFILES) : common_records.scm 30 31 31 %.o : %.scm 32 %.o : %.scm 32 csc -c $< 33 csc -c $< 33 34 34 $(PREFIX)/bin/megatest : megatest 35 $(PREFIX)/bin/megatest : megatest

Modified dashboard-tests.scm from [5d114323130b08d1] to [f1756cabc95a00f8].

109 (store-meta "reviewed" 109 (store-meta "reviewed" 110 (iup:label (db:testmeta-get-reviewed testmeta) #:expand 110 (iup:label (db:testmeta-get-reviewed testmeta) #:expand 111 (lambda (testmeta)(db:testmeta-get-reviewed testmeta))) 111 (lambda (testmeta)(db:testmeta-get-reviewed testmeta))) 112 (store-meta "tags" 112 (store-meta "tags" 113 (iup:label (db:testmeta-get-tags testmeta) #:expand "HO 113 (iup:label (db:testmeta-get-tags testmeta) #:expand "HO 114 (lambda (testmeta)(db:testmeta-get-tags testmeta))) 114 (lambda (testmeta)(db:testmeta-get-tags testmeta))) 115 (store-meta "description" 115 (store-meta "description" 116 (iup:label (db:testmeta-get-description testmeta) #:exp | 116 (iup:label (db:testmeta-get-description testmeta) #:siz 117 (lambda (testmeta)(db:testmeta-get-description testmeta 117 (lambda (testmeta)(db:testmeta-get-description testmeta 118 ))))) 118 ))))) 119 119 120 120 121 ;;====================================================================== 121 ;;====================================================================== 122 ;; Run info panel 122 ;; Run info panel 123 ;;====================================================================== 123 ;;====================================================================== ................................................................................................................................................................................ 198 #:title "Set fields" 198 #:title "Set fields" 199 (iup:vbox 199 (iup:vbox 200 (iup:hbox (iup:label "Comment:") 200 (iup:hbox (iup:label "Comment:") 201 (iup:textbox #:action (lambda (val a b) 201 (iup:textbox #:action (lambda (val a b) 202 (db:test-set-state-status-by-id *db* tes 202 (db:test-set-state-status-by-id *db* tes 203 (set! newcomment b)) 203 (set! newcomment b)) 204 #:value (db:test-get-comment testdat) 204 #:value (db:test-get-comment testdat) 205 #:expand "YES")) | 205 #:expand "HORIZONTAL")) 206 (apply iup:hbox 206 (apply iup:hbox 207 (iup:label "STATE:" #:size "30x") 207 (iup:label "STATE:" #:size "30x") 208 (let* ((btns (map (lambda (state) 208 (let* ((btns (map (lambda (state) 209 (let ((btn (iup:button state 209 (let ((btn (iup:button state 210 #:expand "YES" #:size " | 210 #:expand "HORIZONTAL" # 211 #:action (lambda (x) 211 #:action (lambda (x) 212 (db:test-set 212 (db:test-set 213 (db:test-set 213 (db:test-set 214 btn)) 214 btn)) 215 (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOT 215 (list "COMPLETED" "NOT_STARTED" "RUNNING" "REMOT 216 (vector-set! *state-status* 0 216 (vector-set! *state-status* 0 217 (lambda (state color) 217 (lambda (state color) ................................................................................................................................................................................ 223 (iup:attribute-set! btn "BGCOLOR" newcolo 223 (iup:attribute-set! btn "BGCOLOR" newcolo 224 btns))) 224 btns))) 225 btns)) 225 btns)) 226 (apply iup:hbox 226 (apply iup:hbox 227 (iup:label "STATUS:" #:size "30x") 227 (iup:label "STATUS:" #:size "30x") 228 (let* ((btns (map (lambda (status) 228 (let* ((btns (map (lambda (status) 229 (let ((btn (iup:button status 229 (let ((btn (iup:button status 230 #:expand "YES" #:size " | 230 #:expand "HORIZONTAL" # 231 #:action (lambda (x) 231 #:action (lambda (x) 232 (db:test-set 232 (db:test-set 233 (db:test-set 233 (db:test-set 234 btn)) 234 btn)) 235 (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVE 235 (list "PASS" "WARN" "FAIL" "CHECK" "n/a" "WAIVE 236 (vector-set! *state-status* 1 236 (vector-set! *state-status* 1 237 (lambda (status color) 237 (lambda (status color) ................................................................................................................................................................................ 323 (begin 323 (begin 324 ;(mutex-lock! mx1) 324 ;(mutex-lock! mx1) 325 (iup:attribute-set! lbl "TIT 325 (iup:attribute-set! lbl "TIT 326 ;(mutex-unlock! mx1) 326 ;(mutex-unlock! mx1) 327 ))))) 327 ))))) 328 lbl)) 328 lbl)) 329 (store-button store-label) 329 (store-button store-label) 330 (command-text-box (iup:textbox #:expand "YES" #:font "Courier New, -10" | 330 (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier Ne 331 (command-launch-button (iup:button "Execute!" #:action (lambda (x) 331 (command-launch-button (iup:button "Execute!" #:action (lambda (x) 332 (let ((cmd (iu 332 (let ((cmd (iu 333 (system (con 333 (system (con 334 (run-test (lambda (x) 334 (run-test (lambda (x) 335 (iup:attribute-set! 335 (iup:attribute-set! 336 command-text-box "VALUE" 336 command-text-box "VALUE" 337 (conc "megatest -runtests " testname " " keystring " :run 337 (conc "megatest -runtests " testname " " keystring " :run

Modified dashboard.scm from [8573d45a21bb729a] to [1bf80313b8425968].

24 (declare (uses items)) 24 (declare (uses items)) 25 (declare (uses db)) 25 (declare (uses db)) 26 (declare (uses configf)) 26 (declare (uses configf)) 27 (declare (uses process)) 27 (declare (uses process)) 28 (declare (uses launch)) 28 (declare (uses launch)) 29 (declare (uses runs)) 29 (declare (uses runs)) 30 (declare (uses dashboard-tests)) 30 (declare (uses dashboard-tests)) > 31 (declare (uses dashboard-guimonitor)) 31 (declare (uses megatest-version)) 32 (declare (uses megatest-version)) 32 33 33 (include "common_records.scm") 34 (include "common_records.scm") 34 (include "db_records.scm") 35 (include "db_records.scm") 35 (include "run_records.scm") 36 (include "run_records.scm") 36 37 37 (define help (conc 38 (define help (conc 38 "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest 39 "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest 39 version " megatest-version " 40 version " megatest-version " 40 license GPL, Copyright (C) Matt Welland 2011 41 license GPL, Copyright (C) Matt Welland 2011 41 42 42 Usage: dashboard [options] 43 Usage: dashboard [options] 43 -h : this help 44 -h : this help 44 -run runid : control run identified by runid < 45 -test testid : control test identified by testid 45 -test testid : control test identified by testid > 46 -guimonitor : control panel for runs 46 47 47 Misc 48 Misc 48 -rows N : set number of rows 49 -rows N : set number of rows 49 ")) 50 ")) 50 51 51 ;; process args 52 ;; process args 52 (define remargs (args:get-args 53 (define remargs (args:get-args ................................................................................................................................................................................ 53 (argv) 54 (argv) 54 (list "-rows" 55 (list "-rows" 55 "-run" 56 "-run" 56 "-test" 57 "-test" 57 "-debug" 58 "-debug" 58 ) 59 ) 59 (list "-h" 60 (list "-h" > 61 "-guimonitor" 60 "-v" 62 "-v" 61 "-q" 63 "-q" 62 ) 64 ) 63 args:arg-hash 65 args:arg-hash 64 0)) 66 0)) 65 67 66 (if (args:get-arg "-h") 68 (if (args:get-arg "-h") ................................................................................................................................................................................ 457 (update-search "test-name" val))) 459 (update-search "test-name" val))) 458 (iup:textbox #:size "60x15" #:fontsize "10" #:value "%" 460 (iup:textbox #:size "60x15" #:fontsize "10" #:value "%" 459 #:action (lambda (obj unk val) 461 #:action (lambda (obj unk val) 460 (set! *last-db-update-time* 0) 462 (set! *last-db-update-time* 0) 461 (update-search "item-name" val))))) 463 (update-search "item-name" val))))) 462 (iup:hbox 464 (iup:hbox 463 (iup:button "Quit" #:action (lambda (obj)(sqlite3:finalize! *db*)(e 465 (iup:button "Quit" #:action (lambda (obj)(sqlite3:finalize! *db*)(e > 466 (iup:button "Monitor" #:action (lambda (obj)(system (conc (car (arg 464 )) 467 )) 465 ;; (iup:button "<- Left" #:action (lambda (obj)(set! *start-run-offs 468 ;; (iup:button "<- Left" #:action (lambda (obj)(set! *start-run-offs 466 ;; (iup:button "Up ^" #:action (lambda (obj)(set! *start-test-off 469 ;; (iup:button "Up ^" #:action (lambda (obj)(set! *start-test-off 467 ;; (iup:button "Down v" #:action (lambda (obj)(set! *start-test-off 470 ;; (iup:button "Down v" #:action (lambda (obj)(set! *start-test-off 468 ;; (iup:button "Right ->" #:action (lambda (obj)(set! *start-run-offs 471 ;; (iup:button "Right ->" #:action (lambda (obj)(set! *start-run-offs 469 (iup:frame 472 (iup:frame 470 #:title "hide" 473 #:title "hide" ................................................................................................................................................................................ 656 ((args:get-arg "-test") 659 ((args:get-arg "-test") 657 (let ((testid (string->number (args:get-arg "-test")))) 660 (let ((testid (string->number (args:get-arg "-test")))) 658 (if testid 661 (if testid 659 (examine-test *db* testid) 662 (examine-test *db* testid) 660 (begin 663 (begin 661 (print "ERROR: testid is not a number " (args:get-arg "-test")) 664 (print "ERROR: testid is not a number " (args:get-arg "-test")) 662 (exit 1))))) 665 (exit 1))))) > 666 ((args:get-arg "-guimonitor") > 667 (gui-monitor *db*)) 663 (else 668 (else 664 (set! uidat (make-dashboard-buttons *num-runs* *num-tests* *dbkeys*)) 669 (set! uidat (make-dashboard-buttons *num-runs* *num-tests* *dbkeys*)) 665 (iup:callback-set! *tim* 670 (iup:callback-set! *tim* 666 "ACTION_CB" 671 "ACTION_CB" 667 (lambda (x) 672 (lambda (x) 668 (run-update x))))) 673 (run-update x))))) 669 ;(print x))))) 674 ;(print x))))) 670 675 671 (iup:main-loop) 676 (iup:main-loop)

Modified db.scm from [2c08171fe350a25a] to [7df6739618012e5d].

123 value REAL, 123 value REAL, 124 expected REAL, 124 expected REAL, 125 tol REAL, 125 tol REAL, 126 units TEXT, 126 units TEXT, 127 comment TEXT DEFAULT '', 127 comment TEXT DEFAULT '', 128 status TEXT DEFAULT 'n/a', 128 status TEXT DEFAULT 'n/a', 129 type TEXT DEFAULT '', 129 type TEXT DEFAULT '', 130 CONSTRAINT test_data UNIQUE (test_id,category,vari | 130 CONSTRAINT test_data_constraint UNIQUE (test_id,ca 131 (sqlite3:execute db "CREATE TABLE IF NOT EXISTS task_queue (id INTEGER 131 (sqlite3:execute db "CREATE TABLE IF NOT EXISTS task_queue (id INTEGER 132 action TEXT DEFAULT '', 132 action TEXT DEFAULT '', 133 owner TEXT, 133 owner TEXT, 134 state TEXT DEFAULT 'new', 134 state TEXT DEFAULT 'new', 135 target TEXT DEFAULT '', 135 target TEXT DEFAULT '', 136 name TEXT DEFAULT '', 136 name TEXT DEFAULT '', 137 test TEXT DEFAULT '', 137 test TEXT DEFAULT '', 138 item TEXT DEFAULT '', 138 item TEXT DEFAULT '', 139 creation_time TIMESTAMP, 139 creation_time TIMESTAMP, 140 execution_time TIMESTAMP;") 140 execution_time TIMESTAMP;") 141 (sqlite3:execute db "CREATE monitors (id INTEGER PRIMARY KEY, | 141 (sqlite3:execute db "CREATE TABLE IF NOT EXISTS monitors (id INTEGER P 142 pid INTEGER, 142 pid INTEGER, 143 start_time TIMESTAMP, 143 start_time TIMESTAMP, 144 last_update TIMESTAMP, 144 last_update TIMESTAMP, 145 hostname TEXT, 145 hostname TEXT, 146 username TEXT);") | 146 username TEXT, > 147 CONSTRAINT monitors_constraint UNIQUE (pid,hostna 147 ;; Must do this *after* running patch db !! No more. 148 ;; Must do this *after* running patch db !! No more. 148 (db:set-var db "MEGATEST_VERSION" megatest-version) 149 (db:set-var db "MEGATEST_VERSION" megatest-version) 149 )) 150 )) 150 db)) 151 db)) 151 152 152 ;;====================================================================== 153 ;;====================================================================== 153 ;; TODO: 154 ;; TODO: ................................................................................................................................................................................ 216 status TEXT DEFAULT 'n/a',foss 217 status TEXT DEFAULT 'n/a',foss 217 CONSTRAINT test_data UNIQUE (test_id,category,vari 218 CONSTRAINT test_data UNIQUE (test_id,category,vari 218 (patch-db)) 219 (patch-db)) 219 ((< mver 1.27) 220 ((< mver 1.27) 220 (db:set-var db "MEGATEST_VERSION" 1.27) 221 (db:set-var db "MEGATEST_VERSION" 1.27) 221 (sqlite3:execute db "ALTER TABLE test_data ADD COLUMN type TEXT DEFAULT ' 222 (sqlite3:execute db "ALTER TABLE test_data ADD COLUMN type TEXT DEFAULT ' 222 (patch-db)) 223 (patch-db)) 223 ((< mver 1.28) | 224 ((< mver 1.29) 224 (db:set-var db "MEGATEST_VERSION" 1.28) | 225 (db:set-var db "MEGATEST_VERSION" 1.29) 225 (sqlite3:execute db "ALTER TABLE test_steps ADD COLUMN logfile TEXT;") 226 (sqlite3:execute db "ALTER TABLE test_steps ADD COLUMN logfile TEXT;") 226 (sqlite3:execute db "ALTER TABLE tests ADD COLUMN shortdir TEXT DEFAULT ' 227 (sqlite3:execute db "ALTER TABLE tests ADD COLUMN shortdir TEXT DEFAULT ' > 228 (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tasks_queue (id INTEGER P > 229 action TEXT DEFAULT '', > 230 owner TEXT, > 231 state TEXT DEFAULT 'new', > 232 target TEXT DEFAULT '', > 233 name TEXT DEFAULT '', > 234 test TEXT DEFAULT '', > 235 item TEXT DEFAULT '', > 236 creation_time TIMESTAMP, > 237 execution_time TIMESTAMP);") > 238 (sqlite3:execute db "CREATE TABLE IF NOT EXISTS monitors (id INTEGER PRIM > 239 pid INTEGER, > 240 start_time TIMESTAMP, > 241 last_update TIMESTAMP, > 242 hostname TEXT, > 243 username TEXT, > 244 CONSTRAINT monitors_constraint UNIQUE (pid,hostna 227 (patch-db)) 245 (patch-db)) 228 ((< mver megatest-version) 246 ((< mver megatest-version) 229 (db:set-var db "MEGATEST_VERSION" megatest-version)))))) 247 (db:set-var db "MEGATEST_VERSION" megatest-version)))))) 230 248 231 ;;====================================================================== 249 ;;====================================================================== 232 ;; meta get and set vars 250 ;; meta get and set vars 233 ;;====================================================================== 251 ;;======================================================================

Modified megatest-version.scm from [d71a89278800919b] to [77298102e9662cdc].

1 ;; Always use two digit decimal 1 ;; Always use two digit decimal 2 ;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. 2 ;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. 3 3 4 (declare (unit megatest-version)) 4 (declare (unit megatest-version)) 5 5 6 (define megatest-version 1.28) | 6 (define megatest-version 1.29) 7 7

Modified megatest.scm from [d64eb95b04d14326] to [510b81566b530422].

84 -keepgoing : continue running until no jobs are \"LAUNCHED\" or 84 -keepgoing : continue running until no jobs are \"LAUNCHED\" or 85 \"NOT_STARTED\" 85 \"NOT_STARTED\" 86 -rerun FAIL,WARN... : re-run if called on a test that previously ran (null 86 -rerun FAIL,WARN... : re-run if called on a test that previously ran (null 87 if -keepgoing is also specified) 87 if -keepgoing is also specified) 88 -rebuild-db : bring the database schema up to date 88 -rebuild-db : bring the database schema up to date 89 -rollup : fill run (set by :runname) with latest test(s) from 89 -rollup : fill run (set by :runname) with latest test(s) from 90 prior runs with same keys 90 prior runs with same keys 91 -rename-run <runb> : rename run (set by :runname) to <runb>, requires key < 92 -update-meta : update the tests metadata for all tests 91 -update-meta : update the tests metadata for all tests > 92 -env2file fname : write the environment to fname.csh and fname.sh > 93 > 94 Spreadsheet generation 93 -extract-ods : extract an open document spreadsheet from the databa 95 -extract-ods : extract an open document spreadsheet from the databa 94 -pathmod path : insert path, i.e. path/runame/itempath/logfile.html 96 -pathmod path : insert path, i.e. path/runame/itempath/logfile.html 95 will clear the field if no rundir/testname/itempath/ 97 will clear the field if no rundir/testname/itempath/ 96 if it contains forward slashes the path will be conv 98 if it contains forward slashes the path will be conv 97 to windows style 99 to windows style 98 -env2file fname : write the environment to fname.csh and fname.sh < 99 100 100 Helpers 101 Helpers 101 -runstep stepname ... : take remaining params as comand and execute as stepn 102 -runstep stepname ... : take remaining params as comand and execute as stepn 102 log will be in stepname.log. Best to put command in 103 log will be in stepname.log. Best to put command in 103 -logpro file : with -exec apply logpro file to stepname.log, create 104 -logpro file : with -exec apply logpro file to stepname.log, create 104 stepname.html and sets log to same 105 stepname.html and sets log to same 105 If using make use stepname_logpro.log as your target 106 If using make use stepname_logpro.log as your target

Modified task_records.scm from [80557f0cbbe3a604] to [185f9a143613fea8].

19 (define-inline (tasks:task-get-name vec) (vector-ref vec 5)) 19 (define-inline (tasks:task-get-name vec) (vector-ref vec 5)) 20 (define-inline (tasks:task-get-test vec) (vector-ref vec 6)) 20 (define-inline (tasks:task-get-test vec) (vector-ref vec 6)) 21 (define-inline (tasks:task-get-item vec) (vector-ref vec 7)) 21 (define-inline (tasks:task-get-item vec) (vector-ref vec 7)) 22 (define-inline (tasks:task-get-creation_time vec) (vector-ref vec 8)) 22 (define-inline (tasks:task-get-creation_time vec) (vector-ref vec 8)) 23 (define-inline (tasks:task-get-execution_time vec) (vector-ref vec 9)) 23 (define-inline (tasks:task-get-execution_time vec) (vector-ref vec 9)) 24 24 25 25 26 ;; make-vector-record tasks monitor pid start_time last_update hostname username | 26 ;; make-vector-record tasks monitor id pid start_time last_update hostname usern 27 (define (make-tasks:monitor)(make-vector 5)) 27 (define (make-tasks:monitor)(make-vector 5)) > 28 (define-inline (tasks:monitor-get-id vec) (vector-ref vec 0)) 28 (define-inline (tasks:monitor-get-pid vec) (vector-ref vec 0)) | 29 (define-inline (tasks:monitor-get-pid vec) (vector-ref vec 1)) 29 (define-inline (tasks:monitor-get-start_time vec) (vector-ref vec 1)) | 30 (define-inline (tasks:monitor-get-start_time vec) (vector-ref vec 2)) 30 (define-inline (tasks:monitor-get-last_update vec) (vector-ref vec 2)) | 31 (define-inline (tasks:monitor-get-last_update vec) (vector-ref vec 3)) 31 (define-inline (tasks:monitor-get-hostname vec) (vector-ref vec 3)) | 32 (define-inline (tasks:monitor-get-hostname vec) (vector-ref vec 4)) 32 (define-inline (tasks:monitor-get-username vec) (vector-ref vec 4)) | 33 (define-inline (tasks:monitor-get-username vec) (vector-ref vec 5))

Modified tasks.scm from [3678acac0439e361] to [1354231a437c96b4].

5 ;; 5 ;; 6 ;; This program is distributed WITHOUT ANY WARRANTY; without even the 6 ;; This program is distributed WITHOUT ANY WARRANTY; without even the 7 ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR 7 ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR 8 ;; PURPOSE. 8 ;; PURPOSE. 9 9 10 ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') 10 ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') 11 11 12 (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking) | 12 (use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format) 13 (import (prefix sqlite3 sqlite3:)) 13 (import (prefix sqlite3 sqlite3:)) 14 14 15 (declare (unit runs)) | 15 (declare (unit tasks)) 16 (declare (uses db)) 16 (declare (uses db)) 17 (declare (uses common)) 17 (declare (uses common)) 18 (declare (uses items)) < 19 (declare (uses runconfig)) < 20 18 21 (include "common_records.scm") < 22 (include "key_records.scm") < 23 (include "db_records.scm") < 24 (include "run_records.scm") < 25 (include "task_records.scm") 19 (include "task_records.scm") 26 20 27 ;;====================================================================== 21 ;;====================================================================== 28 ;; Tasks and Task monitors 22 ;; Tasks and Task monitors 29 ;;====================================================================== 23 ;;====================================================================== 30 24 31 25 ................................................................................................................................................................................ 40 ;;====================================================================== 34 ;;====================================================================== 41 35 42 (define (tasks:register-monitor db) 36 (define (tasks:register-monitor db) 43 (let* ((pid (current-process-id)) 37 (let* ((pid (current-process-id)) 44 (hostname (get-host-name)) 38 (hostname (get-host-name)) 45 (userinfo (user-information (current-user-id))) 39 (userinfo (user-information (current-user-id))) 46 (username (car userinfo))) 40 (username (car userinfo))) > 41 (print "Register monitor, pid: " pid ", hostname: " hostname ", username: " 47 (sqlite3:execute db "INSERT INTO monitors (pid,start_time,last_update,hostna 42 (sqlite3:execute db "INSERT INTO monitors (pid,start_time,last_update,hostna 48 pid hostname username))) 43 pid hostname username))) 49 44 50 (define (tasks:get-num-alive-monitors db) 45 (define (tasks:get-num-alive-monitors db) 51 (let ((res 0)) 46 (let ((res 0)) 52 (sqlite3:for-each-row 47 (sqlite3:for-each-row 53 (lambda (count) 48 (lambda (count) 54 (set! res count)) 49 (set! res count)) 55 db 50 db 56 "SELECT count(id) FROM monitors WHERE last_update < (strftime('%s','now') - 51 "SELECT count(id) FROM monitors WHERE last_update < (strftime('%s','now') - 57 (car (user-information (current-user-id)))) 52 (car (user-information (current-user-id)))) 58 res)) 53 res)) 59 54 > 55 ;; register a task > 56 (define (tasks:add db action owner target runname test item) > 57 (sqlite3:execute db "INSERT INTO tasks_queue (action,owner,state,target,name,t > 58 VALUES (?,?,'new',?,?,?,?,strftime('%s','now'),0);" > 59 action > 60 owner > 61 target > 62 runname > 63 test > 64 item)) > 65 > 66 (define (keys:key-vals-hash->target keys key-params) > 67 (let ((tmp (hash-table-ref/default key-params (vector-ref (car keys) 0) ""))) > 68 (if (> (length keys) 1) > 69 (for-each (lambda (key) > 70 (set! tmp (conc tmp "/" (hash-table-ref/default key-params ( > 71 (cdr keys))) > 72 tmp)) > 73 > 74 ;; for use from the gui > 75 (define (tasks:add-from-params db action keys key-params var-params) > 76 (let ((target (keys:key-vals-hash->target keys key-params)) > 77 (owner (car (user-information (current-user-id)))) > 78 (runname (hash-table-ref/default var-params "runname" #f)) > 79 (testpatts (hash-table-ref/default var-params "testpatts" "%")) > 80 (itempatts (hash-table-ref/default var-params "itempatts" "%"))) > 81 (tasks:add db action owner target runname testpatts itempatts))) > 82 60 ;; return one task from those who are 'new' OR 'waiting' AND more than 10sec old 83 ;; return one task from those who are 'new' OR 'waiting' AND more than 10sec old 61 ;; 84 ;; 62 (define (tasks:snag-a-task db) 85 (define (tasks:snag-a-task db) 63 (let ((res #f)) 86 (let ((res #f)) 64 (with-transaction 87 (with-transaction 65 db 88 db 66 (lambda () 89 (lambda () > 90 ;; execution time is updated with every snag, wait 10 secs before doing a 67 (sqlite3:for-each-row 91 (sqlite3:for-each-row 68 (lambda (id . rem) 92 (lambda (id . rem) 69 (set! res (apply vector id rem))) 93 (set! res (apply vector id rem))) 70 db 94 db 71 "SELECT id,action,owner,state,target,name,test,item,creation_time,exectu | 95 "SELECT id,action,owner,state,target,name,test,item,creation_time,execut 72 FROM tasks_queue 96 FROM tasks_queue 73 WHERE 97 WHERE 74 state='new' OR (state='waiting' AND | 98 state='new' OR 75 last_update+10 > strftime('%s','now')) | 99 (state='waiting' AND execution_time+10 > strftime('%s','now')) O > 100 state='reset' 76 LIMIT 1;") | 101 ORDER BY state ASC LIMIT 1;") 77 (if res ;; yep, have work to be done 102 (if res ;; yep, have work to be done 78 (begin 103 (begin 79 (sqlite3:execute db "UPDATE tasks_queue SET state='inprogress' WHER | 104 (sqlite3:execute db "UPDATE tasks_queue SET state='inprogress',exec 80 (tasks:task-get-id res)) 105 (tasks:task-get-id res)) > 106 res) > 107 #f))))) > 108 > 109 (define (tasks:reset-stuck-tasks db) > 110 (let ((res '())) > 111 (sqlite3:for-each-row > 112 (lambda (id delta) > 113 (set! res (cons id res))) > 114 db > 115 "SELECT id,strftime('%s','now')-execution_time AS delta FROM tasks_queue WH > 116 (sqlite3:execute > 117 db > 118 (conc "UPDATE tasks_queue SET state='reset' WHERE id IN ('" (string-intersp > 119 > 120 ;; return all tasks in the tasks_queue table > 121 ;; > 122 (define (tasks:get-tasks db types states) > 123 (let ((res '())) > 124 (sqlite3:for-each-row > 125 (lambda (id . rem) > 126 (set! res (cons (apply vector id rem) res))) > 127 db > 128 (conc "SELECT id,action,owner,state,target,name,test,item,creation_time,exe > 129 FROM tasks_queue " > 130 ;; WHERE > 131 ;; state IN " statesstr " AND > 132 ;; action IN " actionsstr > 133 " ORDER BY creation_time DESC;")) 81 res)))))) | 134 res)) 82 135 83 (define (tasks:start-monitor db) 136 (define (tasks:start-monitor db) 84 (if (> (tasks:get-num-alive-monitors db) 2) ;; have two running, no need for m 137 (if (> (tasks:get-num-alive-monitors db) 2) ;; have two running, no need for m 85 (debug:print 1 "INFO: Not starting monitor, already have more than two run 138 (debug:print 1 "INFO: Not starting monitor, already have more than two run 86 (let* ((megatestdb (conc *toppath* "/megatest.db")) 139 (let* ((megatestdb (conc *toppath* "/megatest.db")) 87 (last-db-update 0)) ;; (file-modification-time megatestdb))) 140 (last-db-update 0)) ;; (file-modification-time megatestdb))) 88 (task:register-monitor db) 141 (task:register-monitor db) 89 (let loop ((count 0)) | 142 (let loop ((count 0) > 143 (next-touch 0)) ;; next-touch is the time where we need to up 90 ;; if the db has been modified we'd best look at the task queue 144 ;; if the db has been modified we'd best look at the task queue 91 (let ((modtime (file-modification-time megatestdb))) | 145 (let ((modtime (file-modification-time megatestdbpath ))) 92 (if (> modtime last-db-update) 146 (if (> modtime last-db-update) > 147 (tasks:process-queue db last-db-update megatestdb next-touch)) > 148 ;; WARNING: Possible race conditon here!! > 149 ;; should this update be immediately after the task-get-action call > 150 (if (> (current-seconds) next-touch) > 151 (begin > 152 (tasks:monitors-update db) > 153 (loop (+ count 1)(+ (current-seconds) 240))) > 154 (loop (+ count 1) next-touch))))))) > 155 > 156 (define (tasks:process-queue db megatestdbpath) 93 (let* ((task (tasks:snag-a-task db)) | 157 (let* ((task (tasks:snag-a-task db)) 94 (action (if task (tasks:task-get-action task) #f))) | 158 (action (if task (tasks:task-get-action task) #f))) 95 (if action | 159 (if action 96 (case (string->symbol action) | 160 (case (string->symbol action) 97 ((run) (tasks:start-run db task)) | 161 ((run) (tasks:start-run db task)) 98 ((remove) (tasks:remove-runs db task)) | 162 ((remove) (tasks:remove-runs db task)) 99 ((lock) (tasks:lock-runs db task)) | 163 ((lock) (tasks:lock-runs db task)) 100 ((monitor) (tasks:start-monitor db task)) | 164 ;; ((monitor) (tasks:start-monitor db task)) 101 ((rollup) (tasks:rollup-runs db task)) | 165 ((rollup) (tasks:rollup-runs db task)) 102 ((updatemeta)(tasks:update-meta db task)) | 166 ((updatemeta)(tasks:update-meta db task)) 103 ((kill) (tasks:kill-monitors db task)))) | 167 ((kill) (tasks:kill-monitors db task)))))) 104 ;; WARNING: Possible race conditon here!! < 105 ;; should this update be immediately after the task-get-action < 106 (set! modtime (file-modification-time megatestdb))))) < 107 (loop (+ count 1)))))) < > 168 > 169 (define (tasks:get-monitors db) > 170 (let ((res '())) > 171 (sqlite3:for-each-row > 172 (lambda (a . rem) > 173 (set! res (cons (apply vector a rem) res))) > 174 db > 175 "SELECT id,pid,strftime('%m/%d/%Y %H:%M',datetime(start_time,'unixepoch'),' > 176 (reverse res) > 177 )) > 178 > 179 (define (tasks:tasks->text tasks) > 180 (let ((fmtstr "~10a~10a~10a~12a~20a~12a~12a~12a")) > 181 (conc (format #f fmtstr "id" "action" "owner" "state" "target" "runname" "te > 182 (string-intersperse > 183 (map (lambda (task) > 184 (format #f fmtstr > 185 (tasks:task-get-id task) > 186 (tasks:task-get-action task) > 187 (tasks:task-get-owner task) > 188 (tasks:task-get-state task) > 189 (tasks:task-get-target task) > 190 (tasks:task-get-name task) > 191 (tasks:task-get-test task) > 192 (tasks:task-get-item task))) > 193 tasks) "\n")))) > 194 > 195 (define (tasks:monitors->text-table monitors) > 196 (let ((fmtstr "~4a~8a~20a~20a~10a~10a")) > 197 (conc (format #f fmtstr "id" "pid" "start time" "last update" "hostname" "us > 198 (string-intersperse > 199 (map (lambda (monitor) > 200 (format #f fmtstr > 201 (tasks:monitor-get-id monitor) > 202 (tasks:monitor-get-pid monitor) > 203 (tasks:monitor-get-start_time monitor) > 204 (tasks:monitor-get-last_update monitor) > 205 (tasks:monitor-get-hostname monitor) > 206 (tasks:monitor-get-username monitor))) > 207 monitors) > 208 "\n")))) > 209 > 210 ;; update the last_update field with the current time and > 211 ;; if any monitors appear dead, remove them > 212 (define (tasks:monitors-update db) > 213 (sqlite3:execute db "UPDATE monitors SET last_update=strftime('%s','now') WHER > 214 (current-process-id) > 215 (get-host-name)) > 216 (let ((deadlist '())) > 217 (sqlite3:for-each-row > 218 (lambda (id pid host last-update delta) > 219 (print "Going to delete stale record for monitor with pid " pid " on host > 220 (set! deadlist (cons id deadlist))) > 221 db > 222 "SELECT id,pid,hostname,last_update,strftime('%s','now')-last_update AS del > 223 (sqlite3:execute db (conc "DELETE FROM monitors WHERE id IN ('" (string-inte > 224 ) 108 225 109 < 110 < > 226 (define (tasks:remove-monitor-record db) > 227 (sqlite3:execute db "DELETE FROM monitors WHERE pid=? AND hostname=?;" > 228 (current-process-id) > 229 (get-host-name))) 111 230 112 < > 231 (define (tasks:start-run db task) > 232 (print "Starting run " task))

Modified tests/megatest.config from [dd77d506f9e7afcc] to [6d5060d736ea6ee6].

5 5 6 [setup] 6 [setup] 7 # exectutable /path/to/megatest 7 # exectutable /path/to/megatest 8 # max_concurrent_jobs 4 8 # max_concurrent_jobs 4 9 runsdir /tmp/runs 9 runsdir /tmp/runs 10 10 11 [jobtools] 11 [jobtools] > 12 useshell yes 12 # ## launcher launches jobs, the job is managed on the target host 13 # ## launcher launches jobs, the job is managed on the target host 13 ## by megatest, comment out launcher to run local 14 ## by megatest, comment out launcher to run local 14 # workhosts localhost hermes 15 # workhosts localhost hermes 15 launcher nbfake | 16 # launcher nbfake 16 # launcher nodanggood 17 # launcher nodanggood 17 18 18 ## use "xterm -e csi -- " as a launcher to examine the launch environment. 19 ## use "xterm -e csi -- " as a launcher to examine the launch environment. 19 ## exit with (exit) 20 ## exit with (exit) 20 ## get a shell with (system "bash") 21 ## get a shell with (system "bash") 21 # launcher xterm -e csi -- 22 # launcher xterm -e csi -- 22 23