Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -27,11 +27,11 @@ 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 + portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm # module source files MSRCFILES = ftail.scm # Eggs to install (straightforward ones) @@ -165,12 +165,12 @@ 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 -%.o : %.scm - csc $(CSCOPTS) -c $< +%.o : %.scm $(MOFILES) + csc $(CSCOPTS) -c $< $(MOFILES) $(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest utils/mk_wrapper @echo Installing to PREFIX=$(PREFIX) $(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest @@ -216,10 +216,14 @@ chmod a+x $@ $(PREFIX)/bin/mt_runstep : utils/mt_runstep $(INSTALL) $< $@ chmod a+x $@ + +$(PREFIX)/bin/serialize-env: serialize-env.scm + csc serialize-env.scm + $(INSTALL) serialize-env $@ $(PREFIX)/bin/mt_ezstep : utils/mt_ezstep $(INSTALL) $< $@ chmod a+x $@ @@ -274,10 +278,11 @@ chmod a+x $(PREFIX)/bin/dashboard $(INSTALL) dboard $(PREFIX)/bin/.$(ARCHSTR)/dboard install : $(PREFIX)/bin/.$(ARCHSTR) $(PREFIX)/bin/.$(ARCHSTR)/mtest $(PREFIX)/bin/megatest \ $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \ + $(PREFIX)/bin/serialize-env \ $(PREFIX)/bin/nbfind $(PREFIX)/bin/loadrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \ $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun \ $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \ $(PREFIX)/bin/tcmt $(PREFIX)/share/db/mt-pg.sql \ $(PREFIX)/share/js/jquery-3.1.0.slim.min.js @@ -356,24 +361,27 @@ xterm : sd (export BASEPATH=/tmp/$(USER)/basepath ; export PATH="$(PWD)/datashare-testing:$(PATH)" ; xterm &) datashare-testing/spublish : spublish.scm $(OFILES) - csc $(CSCOPTS) spublish.scm $(OFILES) -o datashare-testing/spublish + csc $(CSCOPTS) spublish.scm megatest-version.o margs.o process.o common.o -o datashare-testing/spublish datashare-testing/sretrieve : sretrieve.scm $(OFILES) - csc $(CSCOPTS) sretrieve.scm $(OFILES) -o datashare-testing/sretrieve + csc $(CSCOPTS) sretrieve.scm megatest-version.o margs.o process.o common.o -o datashare-testing/sretrieve datashare-testing/sauthorize : sauthorize.scm $(OFILES) - csc $(CSCOPTS) sauthorize.scm $(OFILES) -o datashare-testing/sauthorize + csc $(CSCOPTS) sauthorize.scm megatest-version.o margs.o process.o common.o -o datashare-testing/sauthorize +sauth-init: + mkdir -p datashare-testing + rm datashare-testing/sauthorize + rm datashare-testing/sretrieve + rm datashare-testing/spublish -sretrieve/sretrieve : datashare-testing/sretrieve - csc $(CSCOPTS) -deploy -deployed sretrieve.scm megatest-version.o margs.o configf.o process.o - chicken-install -keep-installed $(PROXY) -deploy -prefix sretrieve defstruct srfi-18 format sql-de-lite \ - srfi-1 posix regex regex-case srfi-69 +sauth : sauth-init datashare-testing/sauthorize datashare-testing/sretrieve datashare-testing/spublish + # base64 dot-locking \ # csv-xml z3 # "(define (toplevel-command . a) #f)" Index: TODO ================================================================== --- TODO +++ TODO @@ -28,5 +28,7 @@ . Re-work the dbstruct data structure? .. Move main.db to global? .. [ run-id.db inmemdb last-mod last-read last-sync inuse ] . Re-work all queries to use run-id to dereference server . Open main.db directly in calls to -runtests etc. No need to talk remote? +. remove common:faux-lock + Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -78,11 +78,12 @@ login tasks-get-last testmeta-get-record have-incompletes? synchash-get - get-changed-record-ids + get-changed-record-ids + get-run-record-ids )) (define api:write-queries '( get-keys-write ;; dummy "write" query to force server start @@ -156,10 +157,15 @@ (params (vector-ref dat 1)) (start-t (current-milliseconds)) (readonly-mode (dbr:dbstruct-read-only dbstruct)) (readonly-command (member cmd api:read-only-queries)) (writecmd-in-readonly-mode (and readonly-mode (not readonly-command))) + (foo (begin + (common:telemetry-log (conc "api-in:"(->string cmd)) + payload: `((params . ,params))) + + #t)) (res (if writecmd-in-readonly-mode (conc "attempt to run write command "cmd" on a read-only database") (case cmd ;;=============================================== @@ -316,29 +322,38 @@ (run-id (cadr params)) (realparams (cddr params))) (db:general-call dbstruct stmtname realparams))) ((sdb-qry) (apply sdb:qry params)) ((ping) (current-process-id)) - ((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params)) - + ((get-changed-record-ids) (apply db:get-changed-record-ids dbstruct params)) + ((get-run-record-ids) (apply db:get-run-record-ids dbstruct params)) ;; TESTMETA ((testmeta-get-record) (apply db:testmeta-get-record dbstruct params)) ;; TASKS ((find-task-queue-records) (apply tasks:find-task-queue-records dbstruct params)) (else (debug:print 0 *default-log-port* "ERROR: bad api call " cmd) (conc "ERROR: BAD api call " cmd)))))) + ;; save all stats (let ((delta-t (- (current-milliseconds) start-t))) (hash-table-set! *db-api-call-time* cmd (cons delta-t (hash-table-ref/default *db-api-call-time* cmd '())))) (if writecmd-in-readonly-mode - (vector #f res) - (vector #t res))))))) + (begin + (common:telemetry-log (conc "api-out:"(->string cmd)) + payload: `((params . ,params) + (ok-res . #t))) + (vector #f res)) + (begin + (common:telemetry-log (conc "api-out:"(->string cmd)) + payload: `((params . ,params) + (ok-res . #f))) + (vector #t res)))))))) ;; http-server send-response ;; api:process-request ;; db:* ;; Index: cgisetup/models/pgdb.scm ================================================================== --- cgisetup/models/pgdb.scm +++ cgisetup/models/pgdb.scm @@ -137,10 +137,17 @@ ;; 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 @@ -148,26 +155,26 @@ "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) ;; area-id) +(define (pgdb:refresh-run-info dbh run-id state status owner event-time comment fail-count pass-count area-id last_update) ;; area-id) (dbi:exec dbh "UPDATE runs SET - state=?,status=?,owner=?,event_time=?,comment=?,fail_count=?,pass_count=? + state=?,status=?,owner=?,event_time=?,comment=?,fail_count=?,pass_count=?,last_update=? WHERE id=? and area_id=?;" - state status owner event-time comment fail-count pass-count run-id area-id)) + state status owner event-time comment fail-count pass-count last_update 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) +(define (pgdb:insert-run dbh ttype-id target run-name state status owner event-time comment fail-count pass-count area-id last-update) (dbi:exec dbh - "INSERT INTO runs (ttype_id,target,run_name,state,status,owner,event_time,comment,fail_count,pass_count,area_id ) - VALUES (?,?,?,?,?,?,?,?,?,?,?);" - ttype-id target run-name state status owner event-time comment fail-count pass-count area-id)) + "INSERT INTO runs (ttype_id,target,run_name,state,status,owner,event_time,comment,fail_count,pass_count,area_id,last_update) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?);" + ttype-id target run-name state status owner event-time comment fail-count pass-count area-id last-update)) ;;====================================================================== ;; T E S T - S T E P S ;;====================================================================== @@ -175,24 +182,30 @@ (dbi:get-one dbh "SELECT id FROM test_steps WHERE test_id=? AND stepname=? and state = ? ;" test-id stepname state)) -(define (pgdb:insert-test-step dbh test-id stepname state status event_time comment logfile) +(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) - VALUES (?,?,?,?,?,?,?);" - test-id stepname state status event_time logfile comment)) + "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) +(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=? + test_id=?,stepname=?,state=?,status=?,event_time=?,logfile=?,comment=?,last_update=? WHERE id=?;" - test-id stepname state status event_time logfile comment step-id)) + test-id stepname state status event_time logfile comment last-update step-id)) ;;====================================================================== ;; T E S T - D A T A ;;====================================================================== @@ -201,11 +214,17 @@ (dbi:get-one dbh "SELECT id FROM test_data WHERE test_id=? AND category=? and variable = ? ;" test-id category variable)) -(define (pgdb:insert-test-data dbh test-id category variable value expected tol units comment status type) +(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)) @@ -217,21 +236,21 @@ (if (not (real? tol)) (set! tol 0 )) (dbi:exec dbh - "INSERT INTO test_data (test_id, category, variable, value, expected, tol, units, comment, status, type) - VALUES (?,?,?,?,?,?,?,?,?,?);" - test-id category variable value expected tol units comment status type)) + "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) +(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=? + 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 data-id )) + test-id category variable value expected tol units comment status type last-update data-id )) ;;====================================================================== ;; T E S T S @@ -242,33 +261,40 @@ (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) +(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) (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) - VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);" + "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) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);" run-id test-name item-path state status host cpuload diskfree uname - run-dir log-file run-duration comment event-time archived)) + run-dir log-file run-duration comment event-time archived last-update)) ;; 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) +(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) (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=? + run_id=?,test_name=?,item_path=?,state=?,status=?,host=?,cpuload=?,diskfree=?,uname=?,rundir=?,final_logf=?,run_duration=?,comment=?,event_time=?,archived=?,last_update=? WHERE id=?;" run-id test-name item-path state status host cpuload diskfree uname - run-dir log-file run-duration comment event-time archived test-id)) + run-dir log-file run-duration comment event-time archived last-update 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, Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -17,11 +17,11 @@ ;; along with Megatest. If not, see . ;;====================================================================== (use srfi-1 data-structures posix regex-case (prefix base64 base64:) - format dot-locking csv-xml z3 ;; sql-de-lite + 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:) @@ -81,10 +81,11 @@ (length (glob (conc "/proc/" pid "/fd/*"))) (length (filter identity (map socket? (glob (conc "/proc/" pid "/fd/*"))))) ) ) + ;; GLOBALS ;; CONTEXTS (defstruct cxt @@ -337,10 +338,92 @@ ;; '()) ) (if (common:api-changed?) (common:set-last-run-version))) +(define (common:snapshot-file filepath #!key (subdir ".") ) + (if (file-exists? filepath) + (let* ((age-sec (lambda (file) + (if (file-exists? file) + (- (current-seconds) (file-modification-time file)) + 1000000000))) ;; return really old value if file doesn't exist. we want to clobber it if old or not exist. + (ok-flag #t) + (age-mins (lambda (file) (/ (age-sec file) 60))) + (age-hrs (lambda (file) (/ (age-mins file) 60))) + (age-days (lambda (file) (/ (age-hrs file) 24))) + (age-wks (lambda (file) (/ (age-days file) 7))) + (docmd (lambda (cmd) + (cond + (ok-flag + (let ((res (system cmd))) + (cond + ((eq? 0 res) + #t) + (else + (set! ok-flag #f) + (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Command failed with exit code " + (if (< res 0) + res + (/ res 8)) " ["cmd"]" ) + #f)))) + (else + (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Not runnining command due to prior error. ["cmd"]") + #f)))) + (copy (lambda (src dest) (docmd (conc "/bin/cp '"src"' '"dest"'")))) + (copy+zip (lambda (src dest) (docmd (conc "gzip -c - < '"src"' > '"dest"'")))) + (fullpath (realpath filepath)) + (basedir (pathname-directory fullpath)) + (basefile (pathname-strip-directory fullpath)) + ;;(prevfile (conc filepath ".prev.gz")) + (minsfile (conc basedir "/" subdir "/" basefile ".mins.gz")) + (hrsfile (conc basedir "/" subdir "/" basefile ".hrs.gz")) + (daysfile (conc basedir "/" subdir "/" basefile ".days.gz")) + (wksfile (conc basedir "/" subdir "/" basefile ".weeks.gz"))) + + ;; create subdir it not exists + (if (not (directory-exists? (conc basedir "/" subdir))) + (docmd (conc "/bin/mkdir -p '"(conc basedir "/" subdir)"'"))) + + ;; copy&zip to .mins if not exists + (if (not (file-exists? minsfile)) + (copy+zip filepath minsfile)) + ;; copy .mins to .hrs if not exists + (if (not (file-exists? hrsfile)) + (copy minsfile hrsfile)) + ;; copy .hrs to .days if not exists + (if (not (file-exists? daysfile)) + (copy hrsfile daysfile)) + ;; copy .days to .weeks if not exists + (if (not (file-exists? wksfile)) + (copy daysfile wksfile)) + + + ;; if age(.mins.gz) >= 1h: + ;; copy .mins.gz .hrs.gz + ;; copy .mins.gz + (when (>= (age-mins minsfile) 1) + (copy minsfile hrsfile) + (copy+zip filepath minsfile)) + + ;; if age(.hrs.gz) >= 1d: + ;; copy .hrs.gz .days.gz + ;; copy .mins.gz .hrs.gz + (when (>= (age-days hrsfile) 1) + (copy hrsfile daysfile) + (copy minsfile hrsfile)) + + ;; if age(.days.gz) >= 1w: + ;; copy .days.gz .weeks.gz + ;; copy .hrs.gz .days.gz + (when (>= (age-wks daysfile) 1) + (copy daysfile wksfile) + (copy hrsfile daysfile)) + #t) + #f)) + + + ;; Rotate logs, logic: ;; if > 500k and older than 1 week: ;; remove previous compressed log and compress this log ;; WARNING: This proc operates assuming that it is in the directory above the ;; logs directory you wish to log-rotate. @@ -749,15 +832,19 @@ (define *wdnum* 0) (define *wdnum*mutex (make-mutex)) + + +(define (common:human-time) + (time->string (seconds->local-time (current-seconds)) "%Y-%m-%d %H:%M:%S")) + + ;; currently the primary job of the watchdog is to run the sync back to megatest.db from the db in /tmp ;; if we are on the homehost and we are a server (by definition we are on the homehost if we are a server) ;; - - (define (common:readonly-watchdog dbstruct) (thread-sleep! 0.05) ;; delay for startup (debug:print-info 13 *default-log-port* "common:readonly-watchdog entered.") ;; sync megatest.db to /tmp/.../megatst.db (let* ((sync-cool-off-duration 3) @@ -801,10 +888,11 @@ (debug:print-info 13 *default-log-port* "watchdog done.")) (debug:print-info 13 *default-log-port* "no need for watchdog on non-homehost")))) (define (std-exit-procedure) + ;;(common:telemetry-log-close) (on-exit (lambda () 0)) ;;(debug:print-info 13 *default-log-port* "std-exit-procedure called; *time-to-exit*="*time-to-exit*) (let ((no-hurry (if *time-to-exit* ;; hurry up #f (begin @@ -1160,16 +1248,16 @@ (handle-exceptions exn (if (> trynum 0) (let ((delay-time (* (- 5 trynum) 5))) (mutex-unlock! *homehost-mutex*) - (debug:print 0 *default-log-port* "ERROR: Failed to read .homehost file, delaying " delay-time " seconds and trying again, message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Failed to read .homehost file, delaying " delay-time " seconds and trying again, message: " ((condition-property-accessor 'exn 'message) exn)) (thread-sleep! delay-time) (common:get-homehost trynum: (- trynum 1))) (begin (mutex-unlock! *homehost-mutex*) - (debug:print 0 *default-log-port* "ERROR: Failed to read .homehost file after trying five times. Giving up and exiting, message: " ((condition-property-accessor 'exn 'message) exn)) + (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Failed to read .homehost file after trying five times. Giving up and exiting, message: " ((condition-property-accessor 'exn 'message) exn)) (exit 1))) (let ((hhf (conc *toppath* "/.homehost"))) (if (common:file-exists? hhf) (with-input-from-file hhf read-line) (if (file-write-access? *toppath*) @@ -1505,22 +1593,25 @@ (with-output-to-file fullpath (lambda ()(pp dat)))))) ;; get cpu load by reading from /proc/loadavg, return all three values ;; (define (common:get-cpu-load remote-host) - (let* ((actual-hostname (or remote-host (get-host-name) "localhost"))) - (or (common:get-cached-info actual-hostname "cpu-load") - (let ((result (if remote-host - (map (lambda (res) - (if (eof-object? res) 9e99 res)) - (with-input-from-pipe - (conc "ssh " remote-host " cat /proc/loadavg") + (handle-exceptions + exn + '(99 99 99) + (let* ((actual-hostname (or remote-host (get-host-name) "localhost"))) + (or (common:get-cached-info actual-hostname "cpu-load") + (let ((result (if remote-host + (map (lambda (res) + (if (eof-object? res) 9e99 res)) + (with-input-from-pipe + (conc "ssh " remote-host " cat /proc/loadavg") (lambda ()(list (read)(read)(read))))) - (with-input-from-file "/proc/loadavg" - (lambda ()(list (read)(read)(read))))))) - (common:write-cached-info actual-hostname "cpu-load" result) - result)))) + (with-input-from-file "/proc/loadavg" + (lambda ()(list (read)(read)(read))))))) + (common:write-cached-info actual-hostname "cpu-load" result) + result))))) ;; get normalized cpu load by reading from /proc/loadavg and /proc/cpuinfo return all three values and the number of real cpus and the number of threads ;; returns alist '((adj-cpu-load . normalized-proc-load) ... etc. ;; keys: adj-proc-load, adj-core-load, 1m-load, 5m-load, 15m-load ;; @@ -2081,10 +2172,33 @@ ;; clear vars matching pattern, run proc, set vars back ;; if proc is a string run that string as a command with ;; system. ;; +(define *common:orig-env* + (let ((envvars (get-environment-variables))) + (if (get-environment-variable "MT_ORIG_ENV") + (with-input-from-string + (z3:decode-buffer (base64:base64-decode (get-environment-variable "MT_ORIG_ENV"))) + read) + (filter-map (lambda (x) + (if (string-match "^MT_.*" (car x)) + #f + x)) + envvars)))) + +(define (common:with-orig-env proc) + (let ((current-env (get-environment-variables))) + (for-each (lambda (x) (unsetenv (car x))) current-env) + (for-each (lambda (x) (setenv (car x) (cdr x))) *common:orig-env*) + (let ((rv (cond + ((string? proc)(system proc)) + (proc (proc))))) + (for-each (lambda (x) (unsetenv (car x))) *common:orig-env*) + (for-each (lambda (x) (setenv (car x) (cdr x))) current-env) + rv))) + (define (common:without-vars proc . var-patts) (let ((vars (make-hash-table))) (for-each (lambda (vardat) ;; each env var (for-each @@ -2104,20 +2218,21 @@ (lambda (var val) (setenv var val))) vars)) -(define (common:run-a-command cmd #!key (with-vars #f)) +(define (common:run-a-command cmd #!key (with-vars #f) (with-orig-env #f)) (let* ((pre-cmd (dtests:get-pre-command)) (post-cmd (dtests:get-post-command)) (fullcmd (if (or pre-cmd post-cmd) (conc pre-cmd cmd post-cmd) (conc "viewscreen " cmd)))) (debug:print-info 02 *default-log-port* "Running command: " fullcmd) - (if with-vars - (common:without-vars cmd) - (common:without-vars fullcmd "MT_.*")))) + (cond + (with-vars (common:without-vars fullcmd)) + (with-orig-env (common:with-orig-env fullcmd)) + (else (common:without-vars fullcmd "MT_.*"))))) ;;====================================================================== ;; T I M E A N D D A T E ;;====================================================================== @@ -2459,10 +2574,14 @@ ;; simple lock. improve and converge on this one. ;; (define (common:simple-lock keyname) (rmt:no-sync-get-lock keyname)) + +(define (common:simple-unlock keyname #!key (force #f)) + (rmt:no-sync-del! keyname)) + ;;====================================================================== ;; ;;====================================================================== @@ -2658,11 +2777,11 @@ command: command host-port: host-port params: params))) (queue-push cmddat) ;; put request into the queue (nn-send soc "queued")) ;; reply with "queued" - (print "ERROR: BAD request " dat)) + (print "ERROR: ["(common:human-time)"] BAD request " dat)) (loop (nn-recv soc))))) (nn-close soc))) @@ -2935,5 +3054,69 @@ exn #t ;; just ignore it, it might have died in the meantime so joining it will throw an exception (thread-join! thread)) ))) (hash-table-keys *common:thread-punchlist*))) + +(define *common:telemetry-log-state* 'startup) +(define *common:telemetry-log-socket* #f) + +(define (common:telemetry-log-open) + (if (eq? *common:telemetry-log-state* 'startup) + (let* ((serverhost (configf:lookup *configdat* "telemetry" "host")) + (serverport (configf:lookup-number *configdat* "telemetry" "port")) + (user (or (get-environment-variable "USER") "unknown")) + (host (or (get-environment-variable "HOST") "unknown"))) + (set! *common:telemetry-log-state* + (handle-exceptions + exn + (begin + (debug:print-info 0 *default-log-port* "common-telemetry-log open udp port failure") + 'broken) + (if (and serverhost serverport user host) + (let* ((s (udp-open-socket))) + ;;(udp-bind! s #f 0) + (udp-connect! s serverhost serverport) + (set! *common:telemetry-log-socket* s) + 'open) + 'not-needed)))))) + +(define (common:telemetry-log event #!key (payload '())) + (if (eq? *common:telemetry-log-state* 'startup) + (common:telemetry-log-open)) + + (if (eq? 'open *common:telemetry-log-state*) + (handle-exceptions + exn + (begin + (debug:print-info 0 *default-log-port* "common-telemetry-log comms failure ; disabled (no server?)") + ;;(define *common:telemetry-log-state* 'broken-or-no-server-preclose) + ;;(common:telemetry-log-close) + (define *common:telemetry-log-state* 'broken-or-no-server) + (set! *common:telemetry-log-socket* #f) + ) + (if (and *common:telemetry-log-socket* event) ;; TODO - filter on event against telemetry.want-events + (let* ((user (or (get-environment-variable "USER") "unknown")) + (host (or (get-environment-variable "HOST") "unknown")) + (start (conc "[megatest "event"]")) + (toppath (or *toppath* "/dev/null")) + (payload-serialized + (base64:base64-encode + (z3:encode-buffer + (with-output-to-string (lambda () (pp payload)))))) + (msg (conc user":"host":"start":"(current-process-id)":"(car (argv))":" + toppath":"payload-serialized))) + (udp-send *common:telemetry-log-socket* msg)))))) + +(define (common:telemetry-log-close) + (when (or (member *common:telemetry-log-state* '(broken-or-no-server-preclose open)) *common:telemetry-log-socket*) + (handle-exceptions + exn + (begin + (define *common:telemetry-log-state* 'closed-fail) + (debug:print-info 0 *default-log-port* "common-telemetry-log closure failure") + ) + (begin + (define *common:telemetry-log-state* 'closed) + (udp-close-socket *common:telemetry-log-socket*) + (set! *common:telemetry-log-socket* #f))))) + Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -774,14 +774,14 @@ ht)) ;; if (define (configf:read-alist fname) (handle-exceptions - exn - #f - (configf:alist->config - (with-input-from-file fname read)))) + exn + #f + (configf:alist->config + (with-input-from-file fname read)))) (define (configf:write-alist cdat fname) (if (not (common:faux-lock fname)) (debug:print 0 *default-log-port* "INFO: Could not get lock on " fname)) (let* ((dat (configf:config->alist cdat)) Index: dashboard-tests.scm ================================================================== --- dashboard-tests.scm +++ dashboard-tests.scm @@ -360,34 +360,53 @@ btns)))))) (define (dashboard-tests:run-a-step info) #t) -(define (dashboard-tests:step-run-control testdat stepname testconfig) - (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES" - #:title stepname - (iup:vbox ; #:expand "YES" - (iup:label (conc "Step: " stepname "\nNB// These buttons only run the test step\nfor the purpose of debugging.\nNot all database updates are done.")) - (iup:button "Re-run" - #:expand "HORIZONTAL" - #:action (lambda (obj) - (thread-start! - (make-thread (lambda () - (ezsteps:run-from testdat stepname #t)) - (conc "ezstep run single step " stepname))))) - (iup:button "Re-run and continue" - #:expand "HORIZONTAL" - #:action (lambda (obj) - (thread-start! - (make-thread (lambda () - (ezsteps:run-from testdat stepname #f)) - (conc "ezstep run from step " stepname))))) - ;; (iup:button "Refresh test data" - ;; #:expand "HORIZONTAL" - ;; #:action (lambda (obj) - ;; (print "Refresh test data " stepname)) - ))) +;; (define (dashboard-tests:step-run-control testdat stepname testconfig) +;; (let* ((mutex (make-mutex))) +;; (letrec ((dlg +;; (iup:dialog ;; #:close_cb (lambda (a)(exit)) ; #:expand "YES" +;; #:title stepname +;; (iup:vbox ; #:expand "YES" +;; (iup:label (conc "Step: " stepname "\nNB// These buttons only run the test step\nfor the purpose of debugging.\nNot all database updates are done.")) +;; (iup:button "Re-run" +;; #:expand "HORIZONTAL" +;; #:action (lambda (obj) +;; (debug:catch-and-dump (lambda () +;; (thread-start! +;; (make-thread +;; (lambda () +;; (print "BB> started ezsteps:run-from") +;; (debug:catch-and-dump +;; (lambda () +;; (ezsteps:run-from testdat stepname #t)) +;; "dashboard-tests:step-run-control -> ezstep:run-from (1)") +;; (print "BB> done ezsteps:run-from") +;; 'foo) +;; (conc "ezstep run single step " stepname))) +;; ) +;; "step-run-control action"))) +;; (iup:button "Re-run and continue" +;; #:expand "HORIZONTAL" +;; #:action (lambda (obj) +;; (debug:catch-and-dump +;; (lambda () +;; (thread-start! +;; (make-thread (lambda () +;; (ezsteps:run-from testdat stepname #f)) +;; (conc "ezstep run from step " stepname)))) +;; "dashboard-tests:step-run-control -> ezstep:run-from (2)"))) +;; (iup:button "Close" +;; #:action (lambda (obj) +;; (iup:destroy! dlg))) +;; ;; (iup:button "Refresh test data" +;; ;; #:expand "HORIZONTAL" +;; ;; #:action (lambda (obj) +;; ;; (print "Refresh test data " stepname)) +;; )))) +;; dlg))) (define (dashboard-tests:waiver run-id testdat ovrdval cmtcmd) (let* ((wpatt (configf:lookup *configdat* "setup" "waivercommentpatt")) (wregx (if (string? wpatt)(regexp wpatt) #f)) (wmesg (iup:label (if wpatt (conc "Comment must match pattern " wpatt) ""))) @@ -459,11 +478,19 @@ (logfile "/this/dir/better/not/exist") (rundir (if testdat (db:test-get-rundir testdat) logfile)) ;; (testdat-path (conc rundir "/testdat.db")) ;; this gets recalculated until found - (teststeps (if testdat (tests:get-compressed-steps run-id test-id) '())) + (augment-teststeps (lambda (inlov) + (map + (lambda (invec) + (list->vector + `( + ,@(reverse (cdr (reverse (vector->list invec)))) + "rerun this step" "restart from here" ))) + inlov))) + (teststeps (if testdat (augment-teststeps (tests:get-compressed-steps run-id test-id)) '())) (testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ...")) (testname (if testdat (db:test-get-testname testdat) "n/a")) ;; (tests:get-testconfig testdat testname 'return-procs)) (testmeta (if testdat (let ((tm (rmt:testmeta-get-record testname))) @@ -535,11 +562,11 @@ (rmt:get-test-info-by-id run-id test-id ))))) ;; (print "INFO: need-update= " need-update " curr-mod-time = " curr-mod-time) (cond ((and need-update newtestdat) (set! testdat newtestdat) - (set! teststeps (tests:get-compressed-steps run-id test-id)) + (set! teststeps (augment-teststeps (tests:get-compressed-steps run-id test-id))) (set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat))) (set! rundir ;; (filedb:get-path *fdb* (db:test-get-rundir testdat)) ;; ) (set! testfullname (db:test-get-fullname testdat)) ;; (debug:print 0 *default-log-port* "INFO: teststeps=" (intersperse teststeps "\n ")) @@ -594,11 +621,11 @@ ))))) lbl)) (store-button store-label) (command-proc (lambda (command-text-box) (let* ((cmd (iup:attribute command-text-box "VALUE"))) - (common:run-a-command cmd)))) + (common:run-a-command cmd with-orig-env: #t)))) (command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -10" #:action (lambda (obj cnum val) ;; (print "cnum=" cnum) @@ -706,25 +733,25 @@ ;; Replace here with matrix (let ((steps-matrix (iup:matrix #:font "Courier New, -8" #:expand "YES" #:scrollbar "YES" - #:numcol 7 + #:numcol 9 #:numlin 100 - #:numcol-visible 7 + #:numcol-visible 9 #:numlin-visible 5 #:click-cb (lambda (obj lin col status) ;; (if (equal? col 6) - (let* ((mtrx-rc (conc lin ":" 6)) - (fname (iup:attribute obj mtrx-rc))) ;; col)))) - (if (eq? col 6) - (view-a-log fname) - (iup:show - (dashboard-tests:step-run-control - testdat - (iup:attribute obj (conc lin ":" 1)) - teststeps)))))))) + (let* ((mtrx-rc (conc lin ":" 6)) + (fname (iup:attribute obj mtrx-rc)) + (stepname (iup:attribute obj (conc lin ":" 1))) (comment (iup:attribute obj (conc lin ":" 7)))) + (case col + + ((7) (print "Comment from step "stepname": "comment)) + ((8) (ezsteps:spawn-run-from testdat stepname #t)) + ((9) (ezsteps:spawn-run-from testdat stepname #f)) + (else (view-a-log fname)))))))) ;; (let loop ((count 0)) ;; (iup:attribute-set! steps-matrix "FITTOTEXT" (conc "L" count)) ;; (if (< count 30) ;; (loop (+ count 1)))) (iup:attribute-set! steps-matrix "0:1" "Step Name") @@ -734,10 +761,15 @@ (iup:attribute-set! steps-matrix "0:4" "Status") (iup:attribute-set! steps-matrix "WIDTH4" "50") (iup:attribute-set! steps-matrix "0:5" "Duration") (iup:attribute-set! steps-matrix "0:6" "Log File") (iup:attribute-set! steps-matrix "0:7" "Comment") + (iup:attribute-set! steps-matrix "0:8" "rerun only") + (iup:attribute-set! steps-matrix "BGCOLOR0:9" "149 208 252") + (iup:attribute-set! steps-matrix "BGCOLOR0:8" "149 208 252") + (iup:attribute-set! steps-matrix "BGCOLOR0:7" "149 208 252") + (iup:attribute-set! steps-matrix "0:9" "rerun & continue") (iup:attribute-set! steps-matrix "ALIGNMENT1" "ALEFT") ;; (iup:attribute-set! steps-matrix "FIXTOTEXT" "C1") (iup:attribute-set! steps-matrix "RESIZEMATRIX" "YES") (let ((proc (lambda (testdat) Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -1424,16 +1424,19 @@ ;; (iup:split ;; #:value 300 ;; Target, testpatt, state and status input boxes ;; - (iup:vbox - ;; Command to run, placed over the top of the canvas - (dcommon:command-action-selector commondat tabdat tab-num: tab-num) - (dboard:runs-tree-browser commondat tabdat) - (dcommon:command-runname-selector commondat tabdat tab-num: tab-num) - (dcommon:command-testname-selector commondat tabdat update-keyvals)) + (iup:split + #:orientation "HORIZONTAL" + (iup:vbox + ;; Command to run, placed over the top of the canvas + (dcommon:command-action-selector commondat tabdat tab-num: tab-num) + (dboard:runs-tree-browser commondat tabdat)) + (iup:vbox + (dcommon:command-runname-selector commondat tabdat tab-num: tab-num) + (dcommon:command-testname-selector commondat tabdat update-keyvals))) ;; key-listboxes)) (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state)))) (tb (dboard:tabdat-runs-tree tabdat))) (dboard:commondat-add-updater commondat Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -332,10 +332,15 @@ ;(tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) ;if wal mode is on -WAL and -shm file get created when db:open-megatest-db is called. modtimedelta will always be < 10 so db in tmp not get synced ;(tmpdbmodtime (if dbfexists (db:get-last-update-time (car tmpdb)) #f)) ;(fmt (file-modification-time tmpdbfname)) (modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime)))) + + (when write-access + (sqlite3:execute (car mtdb) "drop trigger if exists update_tests_trigger") + (sqlite3:execute (car mtdb) "drop trigger if exists update_runs_trigger")) + ;(print "mtdbmodtime " mtdbmodtime " tmpdbmodtime " tmpdbmodtime " mtdbpath " mtdbpath " " (conc *toppath* "/megatest.db")) ;;(debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access) (if (and dbexists (not write-access)) (begin (set! *db-write-access* #f) @@ -401,10 +406,13 @@ ;; Open the classic megatest.db file (defaults to open in toppath) ;; ;; NOTE: returns a dbdat not a dbstruct! ;; + +;;(define (db:reopen-megatest-db + (define (db:open-megatest-db #!key (path #f)(name #f)) (let* ((dbdir (or path *toppath*)) (dbpath (conc dbdir "/" (or name "megatest.db"))) (dbexists (common:file-exists? dbpath)) (db (db:lock-create-open dbpath @@ -510,20 +518,22 @@ '("run_duration" #f) '("comment" #f) '("event_time" #f) '("fail_count" #f) '("pass_count" #f) - '("archived" #f)) + '("archived" #f) + '("last_update" #f)) (list "test_steps" '("id" #f) '("test_id" #f) '("stepname" #f) '("state" #f) '("status" #f) '("event_time" #f) '("comment" #f) - '("logfile" #f)) + '("logfile" #f) + '("last_update" #f)) (list "test_data" '("id" #f) '("test_id" #f) '("category" #f) '("variable" #f) @@ -531,11 +541,12 @@ '("expected" #f) '("tol" #f) '("units" #f) '("comment" #f) '("status" #f) - '("type" #f)))) + '("type" #f) + '("last_update" #f)))) ;; needs db to get keys, this is for syncing all tables ;; (define (db:sync-main-list dbstruct) (let ((keys (db:get-keys dbstruct))) @@ -547,11 +558,11 @@ (list "metadat" '("var" #f) '("val" #f)) (append (list "runs" '("id" #f)) (map (lambda (k)(list k #f)) (append keys - (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" )))) + (list "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update")))) (list "test_meta" '("id" #f) '("testname" #f) '("owner" #f) '("description" #f) @@ -728,11 +739,11 @@ "last_update" (car last-update)) #f)) (num-fields (length fields)) (field->num (make-hash-table)) - (num->field (apply vector (map car fields))) + (num->field (apply vector (map car fields))) ;; BBHERE (full-sel (conc "SELECT " (string-intersperse (map car fields) ",") " FROM " tablename (if use-last-update ;; apply last-update criteria (conc " WHERE " last-update-field " >= " last-update-value) "") ";")) @@ -741,11 +752,14 @@ (fromdat '()) (fromdats '()) (totrecords 0) (batch-len (string->number (or (configf:lookup *configdat* "sync" "batchsize") "100"))) (todat (make-hash-table)) - (count 0)) + (count 0) + + (delay-handicap (string->number (or (configf:lookup *configdat* "sync" "delay-handicap") "0"))) + ) ;; set up the field->num table (for-each (lambda (field) (hash-table-set! field->num field count) @@ -769,17 +783,23 @@ (set! fromdats (cons fromdat fromdats))) (if (common:low-noise-print 120 "sync-records") (debug:print-info 4 *default-log-port* "found " totrecords " records to sync")) - ;; read the target table + ;; read the target table; BBHERE (sqlite3:for-each-row (lambda (a . b) (hash-table-set! todat a (apply vector a b))) (db:dbdat-get-db todb) full-sel) + (when (and delay-handicap (> delay-handicap 0)) + (debug:print-info 0 *default-log-port* "imposing synthetic sync delay of "delay-handicap" seconds since sync/delay-handicap is configured") + (thread-sleep! delay-handicap) + (debug:print-info 0 *default-log-port* "synthetic sync delay of "delay-handicap" seconds completed") + ) + ;; first pass implementation, just insert all changed rows (for-each (lambda (targdb) (let* ((db (db:dbdat-get-db targdb)) (stmth (sqlite3:prepare db full-ins))) @@ -1315,11 +1335,16 @@ fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, archived INTEGER DEFAULT 0, -- 0=no, > 1=archive block id where test data can be found last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));") - (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);") + ;; deprecated -- (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);") + + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_run_id_index ON tests (run_id);") ;; new + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_testname_index ON tests (testname,item_path);") ;; new + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_state_status_index ON tests (state, status); ") ;; new + (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests FOR EACH ROW BEGIN UPDATE tests SET last_update=(strftime('%s','now')) WHERE id=old.id; @@ -1620,39 +1645,61 @@ (define (db:find-and-mark-incomplete dbstruct run-id ovr-deadtime) (let* ((incompleted '()) (oldlaunched '()) (toplevels '()) - (deadtime-str (configf:lookup *configdat* "setup" "deadtime")) ;; FIXME suspect test run time & deadtime are not well matched; resulting in COMPLETED/DEAD status of an a-ok running test - (deadtime (if (and deadtime-str - (string->number deadtime-str)) - (string->number deadtime-str) - 7200))) ;; two hours + (deadtime-trim (or ovr-deadtime (configf:lookup-number *configdat* "setup" "deadtime"))) + (server-start-allowance 200) + (server-overloaded-budget 200) + (launch-monitor-off-time (or (configf:lookup-number *configdat* "setup" "test-stats-update-period") 30)) + (launch-monitor-on-time-budget 30) + (launch-monitor-period (+ launch-monitor-off-time launch-monitor-on-time-budget server-overloaded-budget)) + (remotehoststart-deadtime-default (+ server-start-allowance server-overloaded-budget 30)) + (remotehoststart-deadtime (or deadtime-trim remotehoststart-deadtime-default)) + (running-deadtime-default (+ server-start-allowance (* 2 launch-monitor-period))) + (running-deadtime (or deadtime-trim running-deadtime-default)) ;; two minutes (30 seconds between updates, this leaves 3x grace period) + ) (db:with-db dbstruct #f #f (lambda (db) - (if (number? ovr-deadtime)(set! deadtime ovr-deadtime)) - ;; in RUNNING or REMOTEHOSTSTART for more than 10 minutes ;; ;; HOWEVER: this code in run:test seems to work fine ;; (> (- (current-seconds)(+ (db:test-get-event_time testdat) ;; (db:test-get-run_duration testdat))) ;; 600) ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row - (lambda (test-id run-dir uname testname item-path) + (lambda (test-id run-dir uname testname item-path event-time run-duration) + (if (and (equal? uname "n/a") + (equal? item-path "")) ;; this is a toplevel test + ;; what to do with toplevel? call rollup? + (begin + (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) + (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id)) + (begin + (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)) + (debug:print-info 0 *default-log-port* "Found old test in RUNNING state, test-id=" test-id" exceeded running-deadtime "running-deadtime" now="(current-seconds)" event-time="event-time" run-duration="run-duration)))) + db + "SELECT id,rundir,uname,testname,item_path,event_time,run_duration FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING');" + run-id running-deadtime) + + + (sqlite3:for-each-row + (lambda (test-id run-dir uname testname item-path event-time run-duration) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? (begin (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) (debug:print-info 0 *default-log-port* "Found old toplevel test in RUNNING state, test-id=" test-id)) - (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted)))) + (begin + (debug:print-info 0 *default-log-port* "Found old test in REMOTEHOSTSTART state, test-id=" test-id" exceeded running-deadtime "running-deadtime" now="(current-seconds)" event-time="event-time" run-duration="run-duration) + (set! incompleted (cons (list test-id run-dir uname testname item-path run-id) incompleted))))) db - "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('RUNNING','REMOTEHOSTSTART');" - run-id deadtime) + "SELECT id,rundir,uname,testname,item_path,event_time,run_duration FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > (run_duration + ?) AND state IN ('REMOTEHOSTSTART');" + run-id remotehoststart-deadtime) ;; in LAUNCHED for more than one day. Could be long due to job queues TODO/BUG: Need override for this in config ;; ;; (db:delay-if-busy dbdat) (sqlite3:for-each-row @@ -1659,11 +1706,13 @@ (lambda (test-id run-dir uname testname item-path) (if (and (equal? uname "n/a") (equal? item-path "")) ;; this is a toplevel test ;; what to do with toplevel? call rollup? (set! toplevels (cons (list test-id run-dir uname testname item-path run-id) toplevels)) - (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched)))) + (begin + (debug:print-info 0 *default-log-port* "Found old test in LAUNCHED state, test-id=" test-id" 1 day since event_time marked") + (set! oldlaunched (cons (list test-id run-dir uname testname item-path run-id) oldlaunched))))) db "SELECT id,rundir,uname,testname,item_path FROM tests WHERE run_id=? AND (strftime('%s','now') - event_time) > 86400 AND state IN ('LAUNCHED');" run-id) (debug:print-info 18 *default-log-port* "Found " (length oldlaunched) " old LAUNCHED items, " (length toplevels) " old LAUNCHED toplevel tests and " (length incompleted) " tests marked RUNNING but apparently dead.") @@ -1680,15 +1729,15 @@ ;; incompleted)) (min-incompleted-ids (map car incompleted)) ;; do 'em all (all-ids (append min-incompleted-ids (map car oldlaunched)))) (if (> (length all-ids) 0) (begin - (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as INCOMPLETE") + (debug:print 0 *default-log-port* "WARNING: Marking test(s); " (string-intersperse (map conc all-ids) ", ") " as DEAD") (for-each (lambda (test-id) - (db:test-set-state-status dbstruct run-id test-id "COMPLETED" "DEAD" "Test failed to complete")) ;; fix for one aspect of Randy's ticket 1405717332 ;; TODO - fix problem where test goes to COMPLETED/DEAD while in progress, only later to go to COMPLETED/PASS. ref ticket 220546828 - + (db:set-state-status-and-roll-up-items dbstruct run-id test-id 'foo "COMPLETED" "DEAD" "Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead.")) + ;;(db:test-set-state-status dbstruct run-id test-id "COMPLETED" "DEAD" "Test stopped responding while in RUNNING or REMOTEHOSTSTART; presumed dead.")) ;; fix for one aspect of Randy's ticket 1405717332 ;; TODO - fix problem where test goes to COMPLETED/DEAD while in progress, only later to go to COMPLETED/PASS. ref ticket 220546828 all-ids)))))))) ;; ALL REPLACED BY THE BLOCK ABOVE ;; ;; (sqlite3:execute @@ -2515,11 +2564,11 @@ (define (db:get-run-info dbstruct run-id) ;;(if (hash-table-ref/default *run-info-cache* run-id #f) ;; (hash-table-ref *run-info-cache* run-id) (let* ((res (vector #f #f #f #f)) (keys (db:get-keys dbstruct)) - (remfields (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour")) ;; "area_id")) + (remfields (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour" "last_update")) ;; "area_id")) (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) @@ -3055,11 +3104,11 @@ #f test-id)))) (define db:test-record-fields '("id" "run_id" "testname" "state" "status" "event_time" "host" "cpuload" "diskfree" "uname" "rundir" "item_path" - "run_duration" "final_logf" "comment" "shortdir" "attemptnum" "archived")) + "run_duration" "final_logf" "comment" "shortdir" "attemptnum" "archived" "last_update")) ;; fields *must* be a non-empty list ;; (define (db:field->number fieldname fields) (if (null? fields) @@ -3160,13 +3209,13 @@ #f ;; run-id #f (lambda (db) (let ((res #f)) (sqlite3:for-each-row ;; attemptnum added to hold pid of top process (not Megatest) controlling a test - (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived) + (lambda (id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived last-update) ;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 - (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived))) + (set! res (vector id run-id testname state status event-time host cpuload diskfree uname rundir-id item-path run_duration final-logf-id comment short-dir-id attemptnum archived last-update))) db (conc "SELECT " db:test-record-qry-selector " FROM tests WHERE id=?;") test-id) res)))) @@ -3287,16 +3336,16 @@ (db:with-db dbstruct #f #f (lambda (db) - (let* ((res (vector #f #f #f #f #f #f #f #f))) + (let* ((res (vector #f #f #f #f #f #f #f #f #f))) (sqlite3:for-each-row - (lambda (id test-id stepname state status event-time logfile comment) - (set! res (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment))) + (lambda (id test-id stepname state status event-time logfile comment last-update) + (set! res (vector id test-id stepname state status event-time (if (string? logfile) logfile "") comment last-update))) db - "SELECT id,test_id,stepname,state,status,event_time,logfile,comment FROM test_steps WHERE id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; + "SELECT id,test_id,stepname,state,status,event_time,logfile,comment,last_update FROM test_steps WHERE id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-step-id) res)))) (define (db:get-steps-data dbstruct run-id test-id) (db:with-db @@ -3321,16 +3370,16 @@ (db:with-db dbstruct #f #f (lambda (db) - (let* ((res (vector #f #f #f #f #f #f #f #f #f #f #f))) + (let* ((res (vector #f #f #f #f #f #f #f #f #f #f #f #f))) (sqlite3:for-each-row - (lambda (id test-id category variable value expected tol units comment status type ) - (set! res (vector id test-id category variable value expected tol units comment status type))) + (lambda (id test-id category variable value expected tol units comment status type last-update) + (set! res (vector id test-id category variable value expected tol units comment status type last-update))) db - "SELECT id,test_id, category, variable, value, expected, tol, units, comment, status, type FROM test_data WHERE id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; + "SELECT id,test_id, category, variable, value, expected, tol, units, comment, status, type, last_update FROM test_data WHERE id=? ORDER BY id ASC;" ;; event_time DESC,id ASC; test-data-id) res)))) ;; WARNING: Do NOT call this for the parent test on an iterated test @@ -3511,11 +3560,11 @@ (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) db "SELECT id,test_id,category,variable,value,expected,tol,units,comment,status,type FROM test_data WHERE test_id=? AND category LIKE ? ORDER BY category,variable;" test-id categorypatt) (reverse res))))) -;; This routine moved from tdb.scm, tdb:read-test-data +;; This routine moved from tdb.scm, :read-test-data ;; (define (db:read-test-data* dbstruct run-id test-id categorypatt varpatt) (let* ((res '())) (db:with-db dbstruct #f #f @@ -3658,11 +3707,11 @@ (item-path (db:test-get-item-path testdat)) (tl-testdat (db:get-test-info dbstruct run-id test-name "")) (tl-test-id (if tl-testdat (db:test-get-id tl-testdat) #f))) - (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) + (if (member state '("LAUNCHED" "REMOTEHOSTSTART")) (db:general-call dbstruct 'set-test-start-time (list test-id))) (mutex-lock! *db-transaction-mutex*) (db:with-db dbstruct #f #f (lambda (db) @@ -4321,10 +4370,14 @@ ;; ;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED) ;; mode 'toplevel means that tests must be COMPLETED only ;; mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]] ;; mode 'exclusive means this test/item cannot run if the same test/item is LAUNCHED,REMOTEHOSTSTART or RUNNING +;; +;; IDEA for consideration: +;; 1. collect all tests "upstream" +;; 2. any NOT completed and good? if yes => return those as prereqs not met, if no => return null list ;; ;; (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode) (define (db:get-prereqs-not-met dbstruct run-id waitons ref-test-name ref-item-path mode itemmaps) ;; #!key (mode '(normal))(itemmap #f)) ;; BBnote - rollup of an itemized test's overall state/status done in db:set-state-status-and-roll-up-items (append @@ -4364,11 +4417,11 @@ ;; if waiton toplevel is not in both completed and ok status, add as unmet prerequisite (if (or (not waitons) (null? waitons)) '() - (let* ((ref-test-itemized-mode (not (null? (lset-intersection eq? mode '(itemmatch itemwait))))) + (let* ((ref-test-itemized-mode (not (null? (lset-intersection eq? mode '(itemmatch itemwait))))) ;; how is this different from using member? (ref-test-toplevel-mode (not (null? (lset-intersection eq? mode '(toplevel))))) (ref-test-is-toplevel (equal? ref-item-path "")) (ref-test-is-item (not ref-test-is-toplevel)) (unmet-pre-reqs '()) (result '()) @@ -4391,18 +4444,22 @@ (for-each ; test expanded from waiton (lambda (waiton-test) (let* ((waiton-state (db:test-get-state waiton-test)) (waiton-status (db:test-get-status waiton-test)) (waiton-item-path (db:test-get-item-path waiton-test)) ;; BB- this is the upstream itempath + (waiton-test-name (db:test-get-testname waiton-test)) (waiton-is-toplevel (equal? waiton-item-path "")) (waiton-is-item (not waiton-is-toplevel)) (waiton-is-completed (member waiton-state *common:ended-states*)) (waiton-is-running (member waiton-state *common:running-states*)) (waiton-is-killed (member waiton-state *common:badly-ended-states*)) - (waiton-is-ok (member waiton-status *common:well-ended-states*)) - ;; testname-b path-a path-b - (same-itempath (db:compare-itempaths ref-test-name waiton-item-path ref-item-path itemmaps))) ;; (equal? ref-item-path waiton-item-path))) + (waiton-is-ok (member waiton-status *common:well-ended-states*)) + ;; testname-b path-a path-b + (same-itempath (db:compare-itempaths ref-test-name waiton-item-path ref-item-path itemmaps)) ;; (equal? ref-item-path waiton-item-path))) + (real-ref-test-name (car (string-split ref-test-name "/"))) ;; I THINK ref-test-name SHOULD NEVER HAVE THE ITEM_PATH! + (test-and-ref-are-same (equal? real-ref-test-name waiton-test-name))) + (debug:print 4 *default-log-port* "waiton-test-name " waiton-test-name " ref-test-name: " ref-test-name " test-and-ref-are-same: " test-and-ref-are-same) (set! ever-seen #t) ;;(BB> "***consider waiton "waiton-test"/"waiton-item-path"***") (cond ;; case 0 - toplevel of an itemized test, at least one item in prereq has completed ((and waiton-is-item ref-test-is-toplevel ref-test-itemized-mode waiton-is-completed) @@ -4435,14 +4492,15 @@ (member 'toplevel mode)) ;; toplevel does not block on FAIL (and waiton-is-ok (member 'itemmatch mode) ;; itemmatch blocks on not ok ;; TODO: THIS IS PROBABLY A BUG. ITEMMATCH AND ITEMWAIT ARE SYNONYMS!! WHAT HAPPENED OT ITEMWAIT??? )) ;;(BB> "cond4") (set! item-waiton-met #t)) - ((and waiton-is-completed waiton-is-ok same-itempath) ;;(BB> "cond5") (set! item-waiton-met #t)) + ((and waiton-is-completed waiton-is-ok test-and-ref-are-same) ;; probably from [waitons] table + (set! item-waiton-met #t)) (else #t ;;(BB> "condelse") )))) waiton-tests) @@ -4468,10 +4526,32 @@ ;; (if (not ever-seen)(set! result (cons waitontest-name result))))) ((not ever-seen) (set! result (append (if (null? waiton-tests)(list waitontest-name) waiton-tests) result)))))) waitons) (delete-duplicates result))))) +;;====================================================================== +;; To sync individual run +;;====================================================================== +(define (db:get-run-record-ids dbstruct target run keynames test-patt) +(let ((backcons (lambda (lst item)(cons item lst)))) + (db:with-db + dbstruct #f #f + (lambda (db) + (let* ((keystr (string-intersperse + (map (lambda (key val) + (conc key " like '" val "'")) + keynames + (string-split target "/")) + " AND ")) + (run-qry (conc "SELECT id FROM runs WHERE " keystr " and runname='" run"'")) + (test-qry (conc "SELECT id FROM tests WHERE run_id in (" run-qry ") and testname like '" test-patt "'"))) + ;(print run-qry) + `((runs . ,(fold-row backcons '() db run-qry)) + (tests . ,(fold-row backcons '() db test-qry)) + (test_steps . ,(fold-row backcons '() db (conc "SELECT id FROM test_steps WHERE test_id in (" test-qry ")"))) + (test_data . ,(fold-row backcons '() db (conc "SELECT id FROM test_data WHERE test_id in (" test-qry ")" ))) + )))))) ;;====================================================================== ;; Just for sync, procedures to make sync easy ;;====================================================================== @@ -4482,16 +4562,16 @@ ;; no transaction, allow the db to be accessed between the big queries (let ((backcons (lambda (lst item)(cons item lst)))) (db:with-db dbstruct #f #f (lambda (db) - `((runs . ,(fold-row backcons '() db "SELECT id FROM runs WHERE last_update>?" since-time)) - (tests . ,(fold-row backcons '() db "SELECT id FROM tests WHERE last_update>?" since-time)) - (test_steps . ,(fold-row backcons '() db "SELECT id FROM test_steps WHERE last_update>?" since-time)) - (test_data . ,(fold-row backcons '() db "SELECT id FROM test_data WHERE last_update>?" since-time)) + `((runs . ,(fold-row backcons '() db "SELECT id FROM runs WHERE last_update>=?" since-time)) + (tests . ,(fold-row backcons '() db "SELECT id FROM tests WHERE last_update>=?" since-time)) + (test_steps . ,(fold-row backcons '() db "SELECT id FROM test_steps WHERE last_update>=?" since-time)) + (test_data . ,(fold-row backcons '() db "SELECT id FROM test_data WHERE last_update>=?" since-time)) ;; (test_meta . ,(fold-row backcons '() db "SELECT id FROM test_meta WHERE last_update>?" since-time)) - (run_stats . ,(fold-row backcons '() db "SELECT id FROM run_stats WHERE last_update>?" since-time)) + (run_stats . ,(fold-row backcons '() db "SELECT id FROM run_stats WHERE last_update>=?" since-time)) ))))) ;;====================================================================== ;; Extract ods file from the db ;;====================================================================== Index: db_records.scm ================================================================== --- db_records.scm +++ db_records.scm @@ -102,10 +102,11 @@ (define-inline (db:test-get-run_duration vec) (vector-ref vec 12)) (define-inline (db:test-get-final_logf vec) (vector-ref vec 13)) (define-inline (db:test-get-comment vec) (vector-ref vec 14)) (define-inline (db:test-get-process_id vec) (vector-ref vec 16)) (define-inline (db:test-get-archived vec) (vector-ref vec 17)) +(define-inline (db:test-get-last_update vec) (vector-ref vec 18)) ;; (define-inline (db:test-get-pass_count vec) (vector-ref vec 15)) ;; (define-inline (db:test-get-fail_count vec) (vector-ref vec 16)) (define-inline (db:test-get-fullname vec) (conc (db:test-get-testname vec) "/" (db:test-get-item-path vec))) @@ -186,10 +187,11 @@ (define-inline (db:test-data-get-tol vec) (vector-ref vec 6)) (define-inline (db:test-data-get-units vec) (vector-ref vec 7)) (define-inline (db:test-data-get-comment vec) (vector-ref vec 8)) (define-inline (db:test-data-get-status vec) (vector-ref vec 9)) (define-inline (db:test-data-get-type vec) (vector-ref vec 10)) +(define-inline (db:test-data-get-last_update vec) (vector-ref vec 11)) (define-inline (db:test-data-set-id! vec val)(vector-set! vec 0 val)) (define-inline (db:test-data-set-test_id! vec val)(vector-set! vec 1 val)) (define-inline (db:test-data-set-category! vec val)(vector-set! vec 2 val)) (define-inline (db:test-data-set-variable! vec val)(vector-set! vec 3 val)) @@ -204,27 +206,28 @@ ;;====================================================================== ;; S T E P S ;;====================================================================== ;; Run steps ;; make-vector-record "Run steps" db step id test_id stepname step_complete step_pass event_time -(define (make-db:step)(make-vector 7)) +(define (make-db:step)(make-vector 9)) (define-inline (tdb:step-get-id vec) (vector-ref vec 0)) (define-inline (tdb:step-get-test_id vec) (vector-ref vec 1)) (define-inline (tdb:step-get-stepname vec) (vector-ref vec 2)) (define-inline (tdb:step-get-state vec) (vector-ref vec 3)) (define-inline (tdb:step-get-status vec) (vector-ref vec 4)) (define-inline (tdb:step-get-event_time vec) (vector-ref vec 5)) (define-inline (tdb:step-get-logfile vec) (vector-ref vec 6)) (define-inline (tdb:step-get-comment vec) (vector-ref vec 7)) +(define-inline (tdb:step-get-last_update vec) (vector-ref vec 8)) (define-inline (tdb:step-set-id! vec val)(vector-set! vec 0 val)) (define-inline (tdb:step-set-test_id! vec val)(vector-set! vec 1 val)) (define-inline (tdb:step-set-stepname! vec val)(vector-set! vec 2 val)) (define-inline (tdb:step-set-state! vec val)(vector-set! vec 3 val)) (define-inline (tdb:step-set-status! vec val)(vector-set! vec 4 val)) (define-inline (tdb:step-set-event_time! vec val)(vector-set! vec 5 val)) (define-inline (tdb:step-set-logfile! vec val)(vector-set! vec 6 val)) -(define-inline (tdb:step-set-comment! vec vak)(vector-set! vec 7 val)) +(define-inline (tdb:step-set-comment! vec val)(vector-set! vec 7 val)) ;; The steps table (define (make-db:steps-table)(make-vector 5)) (define-inline (tdb:steps-table-get-stepname vec) (vector-ref vec 0)) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -946,24 +946,28 @@ (lambda (x y) (list (+ x 0) ;; xtorig) (+ y 0))) ;; ytorig))) #f #f)) ;; process polyline edges)))) - (llx (if no-dot + (cx (if no-dot ;; this is the centerpoint! curr-x (string->number (list-ref nodedat 2)))) - (lly (if no-dot + (cy (if no-dot curr-y (string->number (list-ref nodedat 3)))) (boxw (if no-dot boxw (string->number (list-ref nodedat 4)))) (boxh (if no-dot boxh (string->number (list-ref nodedat 5)))) - (urx (+ llx boxw)) - (ury (+ lly boxh))) + (boxw/2 (/ boxw 2)) + (boxh/2 (/ boxh 2)) + (urx (+ cx boxw/2)) + (ury (+ cy boxh/2)) + (llx (- cx boxw/2)) + (lly (- cy boxh/2))) ;; if we are in no-dot mode then increment curr-x and curr-y as needed (if no-dot (begin (cond @@ -1150,28 +1154,29 @@ ;; (apply iup:hbox ;; (let* ((dat (dashboard:update-target-selector tabdat action-proc: update-keyvals)) ;; (key-lb (car dat)) ;; (combos (cadr dat))) ;; combos))) - (iup:hbox - ;; Text box for STATES - (iup:frame - #:title "States" - (dashboard:text-list-toggle-box - ;; Move these definitions to common and find the other useages and replace! - (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED") - (lambda (all) - (dboard:tabdat-states-set! tabdat all) - (dashboard:update-run-command tabdat)))) - ;; Text box for STATES - (iup:frame - #:title "Statuses" - (dashboard:text-list-toggle-box - (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD") - (lambda (all) - (dboard:tabdat-statuses-set! tabdat all) - (dashboard:update-run-command tabdat))))))) + ;; (iup:hbox + ;; ;; Text box for STATES + ;; (iup:frame + ;; #:title "States" + ;; (dashboard:text-list-toggle-box + ;; ;; Move these definitions to common and find the other useages and replace! + ;; (map cadr *common:std-states*) ;; '("COMPLETED" "RUNNING" "STUCK" "INCOMPLETE" "LAUNCHED" "REMOTEHOSTSTART" "KILLED") + ;; (lambda (all) + ;; (dboard:tabdat-states-set! tabdat all) + ;; (dashboard:update-run-command tabdat)))) + ;; ;; Text box for STATES + ;; (iup:frame + ;; #:title "Statuses" + ;; (dashboard:text-list-toggle-box + ;; (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD") + ;; (lambda (all) + ;; (dboard:tabdat-statuses-set! tabdat all) + ;; (dashboard:update-run-command tabdat))))) + )) (define (dcommon:command-tests-tasks-canvas tabdat test-records sorted-testnames tests-draw-state) (iup:frame #:title "Tests and Tasks" (let* ((updater #f) @@ -1256,26 +1261,39 @@ ;;====================================================================== ;; S T E P S ;;====================================================================== (define (dcommon:populate-steps teststeps steps-matrix) - (let ((max-row 0) - (max-col 7)) + (let ((max-row 0) + (max-col 9) + (white "255 255 255") + (running-color (car (gutils:get-color-for-state-status "RUNNING" "STARTED"))) + (failcolor (car (gutils:get-color-for-state-status "COMPLETED" "FAIL")))) (if (null? teststeps) (iup:attribute-set! steps-matrix "CLEARVALUE" "CONTENTS") (let loop ((hed (car teststeps)) (tal (cdr teststeps)) (rownum 1) (colnum 1)) (if (> rownum max-row)(set! max-row rownum)) - (let ((val (vector-ref hed (- colnum 1))) - (mtrx-rc (conc rownum ":" colnum))) + (let* ((status (vector-ref hed 3)) + (val (vector-ref hed (- colnum 1))) + (bgcolor (cond + ((member (conc status) '("" "-" "#")) + running-color) + ((member (conc status) '("0" 0)) + white) + (else failcolor))) + (mtrx-rc (conc rownum ":" colnum))) + ;;(print "BB> status=>"status"< bgcolor="bgcolor) (iup:attribute-set! steps-matrix mtrx-rc (if val (conc val) "")) + (if (< colnum 5) + (iup:attribute-set! steps-matrix (conc "BGCOLOR" mtrx-rc) bgcolor)) (if (< colnum max-col) (loop hed tal rownum (+ colnum 1)) (if (not (null? tal)) - (loop (car tal)(cdr tal)(+ rownum 1) 1)))))) + (loop (car tal) (cdr tal) (+ rownum 1) 1)))))) (if (> max-row 0) (begin ;; we are going to speculatively clear rows until we find a row that is already cleared (let loop ((rownum (+ max-row 1)) (colnum 0) ADDED docs/manual/devnotes.txt Index: docs/manual/devnotes.txt ================================================================== --- /dev/null +++ docs/manual/devnotes.txt @@ -0,0 +1,37 @@ +Developer Notes +--------------- + +Collected here are some topics that may interest the megatest developer. + +telemetry +~~~~~~~~~ + +A new feature introduced in v1.6525 allows a centralized debug messaging system. Debugging client-server issues +is greatly aided by a centralized, time coherent log of events across test execution, server, and runner. This +is provided by the telemetry feature + + +source code call example + + +[source,ini] + [telemetry] + host + port + want-events + + +Usage: +1. Add telemetry section to megatest.config +2. Start telemetry daemon telemetry-daemon -a start -l /tmp/my-telemetry.log +3. Run megatest +4. examine / parse telemetry log Index: docs/manual/megatest_manual.html ================================================================== --- docs/manual/megatest_manual.html +++ docs/manual/megatest_manual.html @@ -900,69 +900,10 @@ sqlite3 database. Megatest has been used with the Intel Netbatch and lsf (also known as openlava) batch systems and it should be straightforward to use it with other similar systems.

- -
-

Overview

-
-
-

Stand-alone Megatest Area

-

A single, stand-alone, Megatest based testsuite or "area" is -sufficient for most validation, automation and build problems.

-
-
-Static -
-
-

Megatest is designed as a distributed or decoupled system. This means -you can run the areas stand-alone with no additional -infrastructure. I.e. there are no databases, web servers or other -centralized resources needed. However as your needs grow you can -integrate multiple areas into a bigger system.

-
-

Component Descriptions

-
    -
  1. -

    -Multi-area dashboard and xterm. A gui (the dashboard) is usually the - best option for controlling and launching runs but all operations - can also be done from the commandline. Note: The not yet released - multi-area dashboard replaces the old dashboard for browsing and - controlling runs but for managing a single area the old dashboard - works very well. -

    -
    2. -
  2. -

    -Area/testsuite. This is your testsuite or automation definition and - consists of the information in megatest.config, runconfigs.config - and your testconfigs along with any custom scripting that can’t be - done with the native Megatest features. -

    -
    3. -
  3. -

    -If your testsuite or build automation is too large to run on a - single instance you can distribute your jobs into a compute server - pool. The only current requirements are password-less ssh access and - a network filesystem. -

    -
    4. -
-
-
-
-

Full System Architecture

-
-
-Static -
-
-
-

Installation

@@ -3033,10 +2974,10 @@
Index: docs/megatest-training.odp ================================================================== --- docs/megatest-training.odp +++ docs/megatest-training.odp cannot compute difference between binary files Index: ezsteps.scm ================================================================== --- ezsteps.scm +++ ezsteps.scm @@ -31,10 +31,15 @@ (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 + + (define (ezsteps:run-from testdat start-step-name run-one) (let* ((test-run-dir ;; (filedb:get-path *fdb* (db:test-get-rundir testdat)) ;; ) (testconfig (read-config (conc test-run-dir "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) @@ -55,11 +60,12 @@ (sleep 3) (loop (- count 1)))))) (debug:print-info 0 *default-log-port* "Running in directory " test-run-dir) (if (not (common:file-exists? ".ezsteps"))(create-directory ".ezsteps")) ;; if ezsteps was defined then we are sure to have at least one step but check anyway - (if (not (> (length ezstepslst) 0)) + + (if (not (> (length ezstepslst) 0)) (message-window "ERROR: You can only re-run steps defined via ezsteps") (begin (let loop ((ezstep (car ezstepslst)) (tal (cdr ezstepslst)) (prevstep #f) @@ -108,11 +114,11 @@ )) (let ((exinfo (vector-ref exit-info 2)) (logfna (if logpro-used (conc stepname ".html") ""))) (rmt:teststep-set-status! run-id test-id stepname "end" exinfo #f logfna)) (if logpro-used - (rmt:test-set-log! test-id (conc stepname ".html"))) + (rmt:test-set-log! run-id test-id (conc stepname ".html"))) ;; set the test final status (let* ((this-step-status (cond ((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn) ((eq? (vector-ref exit-info 2) 0) 'pass) (else 'fail))) @@ -130,18 +136,18 @@ " next-status: " next-status " rollup-status: " rollup-status) (case next-status ((warn) (set! rollup-status 2) ;; NB// test-set-status! does rdb calls under the hood - (tests:test-set-status! test-id "RUNNING" "WARN" + (tests:test-set-status! run-id test-id "RUNNING" "WARN" (if (eq? this-step-status 'warn) "Logpro warning found" #f) #f)) ((pass) - (tests:test-set-status! test-id "RUNNING" "PASS" #f #f)) + (tests:test-set-status! run-id test-id "RUNNING" "PASS" #f #f)) (else ;; 'fail (set! rollup-status 1) ;; force fail - (tests:test-set-status! test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f) + (tests:test-set-status! run-id test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f) )))) (if (and (steprun-good? logpro-used (vector-ref exit-info 2)) (not (null? tal))) (if (not run-one) ;; if we got here we completed the step, if run-one is true, stop (loop (car tal) (cdr tal) stepname runflag)))) @@ -148,11 +154,11 @@ (debug:print 4 *default-log-port* "WARNING: a prior step failed, stopping at " ezstep))) ;; Once done with step/steps update the test record ;; (let* ((item-path (db:test-get-item-path testdat)) ;; (item-list->path itemdat)) - (testinfo (rmt:get-testinfo-by-id run-id test-id))) ;; refresh the testdat, call it iteminfo in case need prev/curr + (testinfo (rmt:get-testinfo-state-status run-id test-id))) ;; refresh the testdat, call it iteminfo in case need prev/curr ;; Am I completed? (if (equal? (db:test-get-state testinfo) "RUNNING") ;; (not (equal? (db:test-get-state testinfo) "COMPLETED")) (let ((new-state (if kill-job "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status ;; "COMPLETED" ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test @@ -166,18 +172,27 @@ ((eq? rollup-status 2) ;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN) (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN")) (else "FAIL")))) ;; (db:test-get-status testinfo))) (debug:print-info 2 *default-log-port* "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status) - (tests:test-set-status! test-id + (tests:test-set-status! run-id test-id new-state new-status (args:get-arg "-m") #f) ;; need to update the top test record if PASS or FAIL and this is a subtest (if (not (equal? item-path "")) - (cdb:set-state-status-and-roll-up-items *runremote* run-id test-name item-path new-status)))) + (rmt:set-state-status-and-roll-up-items run-id test-name item-path new-state new-status #f)))) ;; for automated creation of the rollup html file this is a good place... (if (not (equal? item-path "")) - (tests:summarize-items #f run-id test-id test-name #f)) ;; don't force - just update if no + (tests:summarize-items run-id test-id test-name #f)) ;; don't force - just update if no ))) (pop-directory) rollup-status)) + +(define (ezsteps:spawn-run-from testdat start-step-name run-one) + (thread-start! + (make-thread + (lambda () + (ezsteps:run-from testdat start-step-name run-one)) + (conc "ezstep run single step " start-step-name " run-one="run-one))) + ) + ADDED iup-test/Makefile Index: iup-test/Makefile ================================================================== --- /dev/null +++ iup-test/Makefile @@ -0,0 +1,5 @@ +LIBSRC = "<$PATH>/chicken-4.10.0-patch" + + +sample : sample.c + gcc -I$(LIBSRC)/include/ -L$(LIBSRC)/lib -L$(LIBSRC)/lib64 -liup -liupimglib -o sample sample.c ADDED iup-test/matrix.c Index: iup-test/matrix.c ================================================================== --- /dev/null +++ iup-test/matrix.c @@ -0,0 +1,275 @@ +#include +#include +#include +#include + +#undef __IUPDEF_H +#include "iup.h" +#include "iupcontrols.h" +#include "iupcbs.h" +#include "iup_plus.h" + + +#define TEST_IMAGE_SIZE 20 + +static unsigned char image_data_32 [TEST_IMAGE_SIZE*TEST_IMAGE_SIZE*4] = +{ + 000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255, +}; + +static int mousemove_cb(Ihandle *ih, int lin, int col) +{ + printf("mousemove_cb(%d, %d)\n", lin, col); + return IUP_DEFAULT; +} + +static int drop(Ihandle *self, Ihandle *drop, int lin, int col) +{ + printf("drop_cb(%d, %d)\n", lin, col); + if(lin == 3 && col == 1) + { + IupSetAttribute(drop, "1", "A - Test of Very Big String for Dropdown!"); + IupSetAttribute(drop, "2", "B"); + IupSetAttribute(drop, "3", "C"); + IupSetAttribute(drop, "4", "XXX"); + IupSetAttribute(drop, "5", "5"); + IupSetAttribute(drop, "6", "6"); + IupSetAttribute(drop, "7", "7"); + IupSetAttribute(drop, "8", NULL); + IupSetAttribute(drop, "VALUE", "4"); + return IUP_DEFAULT; + } + return IUP_IGNORE; +} + +static int dropcheck_cb(Ihandle *self, int lin, int col) +{ + if (lin == 3 && col == 1) + return IUP_DEFAULT; + if (lin == 4 && col == 4) + return IUP_CONTINUE; + return IUP_IGNORE; +} + +static int togglevalue_cb(Ihandle *self, int lin, int col, int value) +{ + printf("togglevalue_cb(%d, %d)=%d\n", lin, col, value); + return IUP_DEFAULT; +} + +static int click(Ihandle *self, int lin, int col) +{ + printf("click_cb(%d, %d)\n", lin, col); + IupSetAttribute(self,"MARKED", NULL); /* clear all marks */ + IupSetAttributeId2(self,"MARK", lin, 0, "1"); + IupSetfAttribute(self,"REDRAW", "L%d", lin); + return IUP_DEFAULT; +} + +static int enteritem_cb(Ihandle *ih, int lin, int col) +{ + IupSetAttribute(ih,"MARKED", NULL); /* clear all marks */ + IupSetAttributeId2(ih,"MARK", lin, 0, "1"); + IupSetfAttribute(ih,"REDRAW", "L%d", lin); + return IUP_DEFAULT; +} + +static Ihandle* create_matrix(void) +{ + Ihandle* mat = IupMatrix(NULL); + +// IupSetAttribute(mat, "NUMLIN", "3"); + IupSetAttribute(mat, "NUMLIN", "20"); + IupSetAttribute(mat, "NUMCOL", "8"); +// IupSetAttribute(mat, "NUMCOL", "15"); +// IupSetAttribute(mat, "NUMLIN", "3"); +// IupSetAttribute(mat, "NUMCOL", "2"); +// IupSetAttribute(mat, "NUMLIN", "8"); +// IupSetAttribute(mat, "NUMCOL", "5"); +// IupSetAttribute(mat, "ACTIVE", "NO"); +// IupSetAttribute(mat, "EDITHIDEONFOCUS", "NO"); +// IupSetAttribute(mat, "EDITALIGN", "Yes"); +// IupSetAttribute(mat, "EDITFITVALUE", "Yes"); +// IupSetAttribute(mat, "READONLY", "Yes"); + + //IupSetAttribute(mat, "0:0", "Inflation"); + //IupSetAttribute(mat, "1:0", "Medicine\nPharma"); + //IupSetAttribute(mat, "2:0", "Food"); + //IupSetAttribute(mat, "3:0", "Energy"); + //IupSetAttribute(mat, "0:1", "January 2000"); + //IupSetAttribute(mat, "0:2", "February 2000"); + IupSetAttribute(mat, "1:1", "5.6\n3.33"); + IupSetAttribute(mat, "2:1", "2.2"); + IupSetAttribute(mat, "3:2", "Very Very Very Very Very Large Text"); + IupSetAttribute(mat, "1:2", "4.5"); + if (IupGetInt(NULL, "UTF8MODE")) + IupSetAttribute(mat, "2:2", "(çãõáóé)"); + else + IupSetAttribute(mat, "2:2", "(çãõáóé)"); + + IupSetAttribute(mat, "3:1", "3.4"); + IupSetAttribute(mat, "3:3", "Font Test"); +// IupSetAttribute(mat, "HEIGHT2", "30"); +// IupSetAttribute(mat, "WIDTH2", "190"); +// IupSetAttributeId(mat, "WIDTH", 2, "190"); + IupSetAttribute(mat,"SORTSIGN2","DOWN"); +// IupSetAttribute(mat, "WIDTHDEF", "34"); +// IupSetAttribute(mat,"MULTILINE", "YES"); + IupSetAttribute(mat,"RESIZEMATRIX", "YES"); +// IupSetAttribute(mat,"HIDDENTEXTMARKS", "YES"); +// IupSetAttribute(mat,"USETITLESIZE", "YES"); + //IupSetAttribute(mat,"SCROLLBAR", "NO"); + //IupSetAttribute(mat, "BGCOLOR1:2", "255 92 255"); + //IupSetAttribute(mat, "BGCOLOR2:*", "92 92 255"); + //IupSetAttribute(mat, "BGCOLOR*:3", "255 92 92"); + //IupSetAttribute(mat, "FGCOLOR1:2", "255 0 0"); + //IupSetAttribute(mat, "FGCOLOR2:*", "0 128 0"); + //IupSetAttribute(mat, "FGCOLOR*:3", "0 0 255"); + IupSetAttribute(mat, "FONT3:3", "Helvetica, 24"); + //IupSetAttribute(mat, "FONT2:*", "Courier, 14"); + //IupSetAttribute(mat, "FONT*:3", "Times, Bold 14"); +// IupSetAttribute(mat, "ALIGNMENT1", "ALEFT"); +// IupSetAttribute(mat, "ALIGNMENT3", "ARIGHT"); +// IupSetAttribute(mat, "ALIGN2:1", ":ARIGHT"); +// IupSetAttribute(mat, "LINEALIGNMENT1", "ATOP"); + // IupSetAttribute(mat, "ACTIVE", "NO"); +// IupSetAttribute(mat, "EXPAND", "NO"); +// IupSetAttribute(mat, "ALIGNMENT", "ALEFT"); + +// IupSetAttribute(mat, "MASK1:3", IUP_MASK_FLOAT); +// IupSetAttribute(mat, "MASK1:3", "[a-zA-Z][0-9a-zA-Z_]*"); +// IupSetAttribute(mat, "MASKFLOAT1:3", "0.0:10.0"); + IupSetAttribute(mat, "MASK*:3", "[a-zA-Z][0-9a-zA-Z_]*"); + + IupSetAttribute(mat, "TYPE4:1", "COLOR"); + IupSetAttribute(mat, "4:1", "255 0 128"); + + IupSetAttribute(mat, "TYPE4:2", "FILL"); + IupSetAttribute(mat, "4:2", "60"); + IupSetAttribute(mat, "SHOWFILLVALUE", "Yes"); + + { + Ihandle* image = IupImageRGBA(TEST_IMAGE_SIZE, TEST_IMAGE_SIZE, image_data_32); + IupSetAttribute(mat, "TYPE4:3", "IMAGE"); + IupSetAttributeHandle(mat, "4:3", image); + } + +// IupSetAttribute(mat, "TOGGLEVALUE4:4", "ON"); +// IupSetAttribute(mat, "VALUE4:4", "1"); + IupSetAttribute(mat, "TOGGLECENTERED", "Yes"); + + IupSetAttribute(mat,"MARKMODE","CELL"); +// IupSetAttribute(mat,"MARKMODE","LIN"); +// IupSetAttribute(mat,"MARKMULTIPLE","NO"); + IupSetAttribute(mat,"MARKMULTIPLE","YES"); +// IupSetAttribute(mat,"MARKAREA","NOT_CONTINUOUS"); +// IupSetAttribute(mat,"MARK2:2","YES"); +// IupSetAttribute(mat,"MARK2:3","YES"); +// IupSetAttribute(mat,"MARK3:3","YES"); + + IupSetAttribute(mat,"FRAMEVERTCOLOR1:2","BGCOLOR"); + IupSetAttribute(mat,"FRAMEHORIZCOLOR1:2","0 0 255"); + IupSetAttribute(mat,"FRAMEHORIZCOLOR1:3","0 255 0"); + IupSetAttribute(mat,"FRAMEVERTCOLOR2:2","255 255 0"); + IupSetAttribute(mat,"FRAMEVERTCOLOR*:4","0 255 0"); + IupSetAttribute(mat,"FRAMEVERTCOLOR*:5","BGCOLOR"); + +// IupSetAttribute(mat,"MARKMODE","LINCOL"); + + //IupSetAttribute(mat, "NUMCOL_VISIBLE_LAST", "YES"); + //IupSetAttribute(mat, "NUMLIN_VISIBLE_LAST", "YES"); +// IupSetAttribute(mat, "WIDTHDEF", "15"); + IupSetAttribute(mat, "20:8", "The End"); + //IupSetAttribute(mat, "10:0", "Middle Line"); + //IupSetAttribute(mat, "15:0", "Middle Line"); + //IupSetAttribute(mat, "0:4", "Middle Column"); + //IupSetAttribute(mat, "20:0", "Line Title Test"); + //IupSetAttribute(mat, "0:8", "Column Title Test"); + IupSetAttribute(mat, "NUMCOL_VISIBLE", "3"); + IupSetAttribute(mat, "NUMLIN_VISIBLE", "5"); +// IupSetAttribute(mat,"EDITNEXT","COLCR"); +// IupSetAttribute(mat, "NUMCOL_NOSCROLL", "1"); + +// IupSetAttribute(mat, "LIMITEXPAND", "Yes"); +// IupSetAttribute(mat, "XAUTOHIDE", "NO"); +// IupSetAttribute(mat, "YAUTOHIDE", "NO"); + +// IupSetAttribute(mat,"RASTERSIZE","x300"); +// IupSetAttribute(mat,"FITTOSIZE","LINES"); + +// IupSetAttribute(mat,"TYPECOLORINACTIVE","No"); +// IupSetAttribute(mat, "ACTIVE", "No"); + + IupSetAttribute(mat, "FRAMEBORDER", "Yes"); + + /* test for custom matrix attributes */ + //{ + // char* v; + // IupSetAttribute(mat, "MTX_LINE_ACTIVE_FLAG3:4", "Test1"); + // IupSetAttributeId2(mat, "MTX_LINE_ACTIVE_FLAG", 5, 7, "Test2"); + // printf("Test1=%s\n", IupGetAttribute(mat, "MTX_LINE_ACTIVE_FLAG3:4")); + // printf("Test2=%s\n", IupGetAttributeId2(mat, "MTX_LINE_ACTIVE_FLAG", 5, 7)); + //} + + IupSetCallback(mat, "DROPCHECK_CB", (Icallback)dropcheck_cb); + IupSetCallback(mat,"DROP_CB",(Icallback)drop); +// IupSetCallback(mat,"MENUDROP_CB",(Icallback)drop); +// IupSetCallback(mat, "MOUSEMOVE_CB", (Icallback)mousemove_cb); +// IupSetCallback(mat,"CLICK_CB",(Icallback)click); +// IupSetCallback(mat,"ENTERITEM_CB",(Icallback)enteritem_cb); + IupSetCallback(mat,"TOGGLEVALUE_CB",(Icallback)togglevalue_cb); + + return mat; +} + +void MatrixTest(void) +{ + Ihandle* dlg, *box, *mat; + + box = IupVbox(mat = create_matrix(), NULL); + IupSetAttribute(box, "MARGIN", "10x10"); +// IupSetAttribute(box, "FONT", "Arial, 7"); + + dlg = IupDialog(box); + IupSetAttribute(dlg, "TITLE", "IupMatrix Simple Test"); + IupShowXY(dlg, IUP_CENTER, IUP_CENTER); + +// IupSetAttribute(mat, "ADDLIN", "1"); +// IupSetAttribute(mat,"4:0","Teste"); +// IupSetAttribute(mat, "REDRAW", "ALL"); +} + +#ifndef BIG_TEST +int main(int argc, char* argv[]) +{ + IupOpen(&argc, &argv); + IupControlsOpen(); + + MatrixTest(); + + IupMainLoop(); + + IupClose(); + + return EXIT_SUCCESS; +} +#endif ADDED iup-test/sample.c Index: iup-test/sample.c ================================================================== --- /dev/null +++ iup-test/sample.c @@ -0,0 +1,684 @@ +#include +#include +#include +#include + +#undef __IUPDEF_H +#include +#include "iupcontrols.h" +#include "iupcbs.h" + +#define TEST_IMAGE_SIZE 20 + +static unsigned char image_data_32 [TEST_IMAGE_SIZE*TEST_IMAGE_SIZE*4] = +{ + 000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,000,000,255,255,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,255,255,255,192,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,000,255, + 000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255,000,000,000,255, +}; + +static int drop(Ihandle *self, Ihandle *drop, int lin, int col) +{ + printf("drop_cb(%d, %d)\n", lin, col); + if(lin == 3 && col == 1) + { + IupSetAttribute(drop, "1", "A - Test of Very Big String for Dropdown!"); + IupSetAttribute(drop, "2", "B"); + IupSetAttribute(drop, "3", "C"); + IupSetAttribute(drop, "4", "XXX"); + IupSetAttribute(drop, "5", "5"); + IupSetAttribute(drop, "6", "6"); + IupSetAttribute(drop, "7", "7"); + IupSetAttribute(drop, "8", NULL); + IupSetAttribute(drop, "VALUE", "4"); + return IUP_DEFAULT; + } + return IUP_IGNORE; +} + +static int togglevalue_cb(Ihandle *self, int lin, int col, int value) +{ + printf("togglevalue_cb(%d, %d)=%d\n", lin, col, value); + return IUP_DEFAULT; +} + +static Ihandle* load_image_Tecgraf(void) +{ + unsigned char imgdata[] = { + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 88, 95, 108, 1, 90, 100, 117, 99, 123, 138, 166, 126, 137, 152, 181, 60, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 95, 105, 123, 147, 122, 137, 165, 255, 136, 152, 183, 255, 132, 149, 179, 250, 133, 149, 178, 69, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 92, 100, 115, 43, 111, 125, 150, 253, 140, 158, 190, 255, 135, 151, 182, 255, 132, 149, 179, 255, 131, 147, 177, 217, 153, 164, 188, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 102, 113, 134, 148, 134, 151, 182, 255, 137, 154, 185, 255, 115, 129, 154, 252, 114, 128, 155, 255, 130, 146, 175, 255, 132, 147, 175, 71, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 158, 159, 162, 3, 108, 121, 145, 230, 144, 162, 195, 255, 137, 154, 185, 197, 74, 79, 86, 45, 41, 46, 55, 246, 120, 134, 162, 255, 129, 145, 174, 156, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 95, 101, 113, 48, 124, 139, 167, 255, 144, 161, 194, 255, 138, 155, 186, 67, 0, 0, 0, 0, 49, 54, 62, 150, 87, 98, 118, 255, 128, 144, 173, 223, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 102, 113, 132, 105, 137, 154, 185, 255, 139, 156, 188, 231, 143, 159, 187, 3, 0, 0, 0, 0, 64, 68, 76, 61, 70, 79, 95, 255, 127, 143, 172, 254, 134, 149, 175, 25, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 109, 121, 142, 153, 141, 159, 191, 255, 139, 156, 188, 164, 0, 0, 0, 0, 0, 0, 0, 0, 79, 82, 87, 3, 69, 77, 92, 241, 122, 137, 165, 255, 127, 142, 170, 70, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 110, 122, 146, 191, 145, 163, 196, 255, 139, 156, 188, 107, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 77, 86, 101, 190, 115, 129, 156, 255, 126, 141, 170, 113, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 112, 125, 149, 227, 150, 168, 201, 255, 141, 157, 188, 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 82, 91, 107, 144, 113, 127, 153, 255, 125, 140, 169, 144, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 163, 165, 167, 2, 112, 125, 150, 252, 155, 173, 203, 255, 143, 159, 189, 26, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 85, 94, 110, 109, 114, 128, 155, 255, 125, 140, 168, 175, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 160, 167, 181, 1, 120, 130, 149, 33, 48, 53, 59, 69, 43, 46, 52, 100, 50, 54, 59, 137, 116, 130, 156, 255, 155, 171, 201, 255, 105, 118, 142, 155, 104, 117, 141, 151, 105, 118, 141, 151, 105, 118, 142, 151, 101, 113, 136, 185, 111, 124, 150, 255, 116, 130, 156, 220, 112, 125, 148, 95, 115, 127, 150, 67, 123, 134, 156, 33, 168, 176, 190, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 119, 129, 147, 5, 109, 121, 142, 71, 106, 118, 140, 140, 105, 117, 140, 197, 107, 120, 144, 242, 120, 135, 162, 255, 123, 137, 163, 255, 44, 49, 58, 255, 28, 32, 39, 255, 125, 139, 164, 255, 150, 167, 197, 255, 138, 155, 186, 255, 131, 148, 178, 255, 125, 141, 170, 255, 119, 134, 162, 255, 114, 128, 154, 255, 108, 122, 147, 255, 104, 117, 141, 255, 102, 115, 138, 255, 103, 116, 139, 255, 107, 120, 145, 255, 111, 124, 149, 245, 113, 126, 151, 200, 113, 127, 152, 140, 116, 129, 154, 71, 122, 135, 158, 5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 118, 128, 145, 14, 106, 118, 140, 130, 104, 116, 139, 234, 105, 118, 142, 255, 128, 144, 173, 255, 147, 165, 199, 255, 157, 177, 213, 255, 150, 168, 202, 255, 140, 156, 187, 229, 41, 45, 52, 196, 39, 43, 51, 183, 130, 143, 168, 255, 144, 161, 192, 233, 109, 122, 145, 109, 105, 116, 138, 109, 99, 110, 130, 109, 92, 103, 123, 109, 91, 100, 117, 145, 97, 109, 131, 255, 95, 106, 128, 248, 74, 83, 97, 193, 64, 72, 85, 227, 56, 63, 75, 255, 55, 62, 75, 255, 65, 73, 88, 255, 90, 101, 121, 255, 111, 125, 150, 255, 114, 128, 154, 236, 116, 129, 155, 130, 127, 140, 165, 16, 0, 0, 0, 0, + 95, 101, 113, 22, 103, 115, 137, 220, 103, 116, 140, 255, 110, 123, 148, 255, 146, 165, 198, 255, 147, 165, 197, 232, 142, 158, 188, 147, 131, 144, 169, 78, 115, 123, 139, 20, 0, 0, 0, 0, 0, 0, 0, 0, 91, 97, 108, 68, 128, 142, 167, 255, 144, 162, 193, 212, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 95, 100, 107, 31, 120, 135, 163, 255, 133, 150, 180, 231, 0, 0, 0, 0, 0, 0, 0, 0, 86, 89, 93, 20, 50, 54, 61, 73, 37, 40, 46, 141, 33, 36, 42, 230, 46, 52, 63, 255, 107, 120, 144, 255, 116, 130, 157, 255, 118, 133, 159, 223, 132, 147, 174, 24, + 76, 83, 95, 114, 104, 117, 140, 255, 105, 117, 141, 255, 118, 133, 160, 253, 139, 155, 184, 116, 134, 143, 161, 7, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93, 100, 110, 74, 122, 137, 163, 255, 143, 160, 191, 200, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 110, 114, 120, 31, 123, 138, 166, 255, 136, 153, 183, 228, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 90, 93, 97, 5, 42, 45, 51, 111, 86, 97, 117, 253, 118, 133, 160, 255, 119, 133, 161, 255, 133, 149, 180, 116, + 46, 50, 56, 109, 67, 76, 91, 255, 105, 118, 142, 255, 107, 120, 145, 254, 112, 125, 149, 131, 127, 139, 161, 12, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93, 98, 109, 74, 116, 130, 156, 255, 142, 159, 190, 200, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 112, 115, 122, 31, 128, 143, 172, 255, 141, 157, 185, 228, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 124, 137, 163, 7, 122, 136, 162, 122, 120, 135, 162, 254, 121, 136, 164, 255, 136, 152, 184, 255, 126, 141, 168, 116, + 71, 74, 79, 17, 31, 35, 41, 206, 42, 47, 57, 255, 77, 87, 105, 255, 103, 116, 140, 255, 110, 124, 149, 239, 112, 125, 150, 157, 115, 128, 153, 89, 122, 134, 158, 30, 147, 158, 177, 2, 0, 0, 0, 0, 81, 87, 96, 65, 109, 123, 148, 255, 141, 158, 190, 212, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 98, 103, 112, 31, 135, 151, 180, 255, 141, 156, 183, 231, 0, 0, 0, 0, 153, 164, 183, 1, 134, 147, 171, 30, 124, 138, 165, 84, 123, 138, 165, 154, 122, 137, 164, 235, 127, 143, 172, 255, 140, 157, 189, 255, 144, 162, 195, 255, 129, 144, 172, 218, 126, 138, 161, 22, + 0, 0, 0, 0, 64, 68, 73, 7, 39, 43, 49, 118, 32, 36, 42, 225, 30, 35, 42, 255, 50, 57, 68, 255, 72, 81, 97, 255, 91, 102, 123, 255, 105, 118, 142, 255, 113, 127, 152, 240, 115, 129, 155, 204, 111, 124, 149, 196, 111, 125, 150, 255, 126, 141, 170, 234, 119, 133, 159, 120, 120, 134, 160, 116, 121, 135, 161, 117, 121, 135, 162, 119, 116, 130, 155, 152, 127, 142, 170, 255, 125, 140, 168, 248, 123, 138, 166, 199, 130, 145, 173, 235, 140, 155, 183, 255, 143, 160, 190, 255, 143, 161, 193, 255, 147, 165, 199, 255, 145, 164, 197, 255, 132, 148, 177, 230, 127, 140, 166, 126, 124, 134, 151, 12, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 138, 141, 144, 3, 55, 58, 63, 58, 37, 40, 46, 126, 34, 38, 44, 184, 34, 38, 44, 235, 35, 39, 47, 254, 49, 55, 66, 255, 64, 72, 87, 255, 77, 87, 104, 255, 88, 98, 118, 255, 96, 108, 130, 255, 103, 116, 139, 255, 108, 122, 147, 255, 113, 127, 153, 255, 118, 133, 160, 255, 124, 140, 168, 255, 133, 148, 176, 255, 141, 156, 183, 255, 146, 161, 187, 255, 144, 159, 186, 255, 131, 146, 174, 254, 127, 141, 168, 237, 126, 141, 168, 188, 123, 137, 162, 131, 112, 123, 143, 61, 128, 132, 140, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 91, 94, 98, 19, 64, 68, 73, 56, 53, 57, 65, 82, 62, 67, 76, 116, 66, 74, 89, 255, 95, 107, 129, 255, 80, 88, 103, 155, 81, 90, 105, 151, 86, 95, 112, 151, 95, 104, 122, 151, 98, 109, 128, 180, 124, 139, 166, 255, 109, 122, 146, 218, 100, 110, 128, 84, 96, 104, 118, 56, 105, 109, 117, 22, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 173, 174, 176, 2, 74, 83, 98, 252, 131, 147, 178, 255, 140, 155, 184, 29, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 122, 134, 157, 114, 151, 169, 203, 255, 123, 138, 165, 174, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 68, 76, 90, 224, 122, 137, 165, 255, 136, 152, 182, 69, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 125, 139, 165, 147, 146, 164, 198, 255, 122, 137, 165, 144, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 62, 69, 81, 191, 110, 124, 149, 255, 134, 151, 181, 113, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 128, 143, 170, 193, 142, 160, 192, 255, 122, 137, 164, 111, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 58, 63, 74, 150, 94, 105, 127, 255, 133, 149, 179, 166, 0, 0, 0, 0, 0, 0, 0, 0, 115, 119, 128, 5, 130, 145, 174, 242, 137, 154, 186, 255, 125, 139, 166, 70, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 54, 58, 66, 102, 72, 81, 97, 255, 132, 148, 178, 236, 148, 161, 187, 5, 0, 0, 0, 0, 110, 121, 140, 64, 140, 157, 189, 255, 127, 142, 171, 254, 131, 144, 169, 23, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 62, 65, 71, 43, 47, 52, 63, 255, 127, 143, 172, 255, 132, 148, 177, 75, 0, 0, 0, 0, 121, 134, 158, 160, 139, 156, 188, 255, 123, 138, 165, 223, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 154, 156, 158, 1, 36, 39, 46, 227, 106, 119, 143, 255, 130, 145, 175, 203, 114, 125, 147, 51, 123, 138, 166, 247, 131, 147, 177, 255, 123, 138, 165, 151, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 37, 41, 47, 143, 68, 77, 93, 255, 128, 144, 174, 255, 126, 141, 170, 252, 129, 145, 174, 255, 123, 138, 166, 255, 127, 141, 167, 68, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 65, 68, 73, 40, 34, 38, 46, 250, 117, 131, 158, 255, 126, 142, 171, 255, 124, 140, 168, 255, 125, 139, 166, 214, 140, 152, 172, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 41, 44, 50, 134, 58, 66, 79, 255, 123, 138, 166, 255, 123, 138, 166, 250, 127, 140, 165, 66, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 154, 156, 158, 1, 46, 50, 55, 83, 82, 89, 102, 123, 106, 116, 136, 51, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; + + Ihandle* image = IupImageRGBA(32, 32, imgdata); + return image; +} + +static Ihandle* load_image_LogoTecgraf(void) +{ + unsigned char imgdata[] = { + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 108, 120, 143, 125, 132, 148, 178, 173, 133, 149, 178, 17, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 100, 110, 130, 48, 130, 147, 177, 254, 124, 139, 167, 254, 131, 147, 176, 137, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 115, 128, 153, 134, 142, 159, 191, 194, 47, 52, 61, 110, 114, 128, 154, 222, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 128, 143, 172, 192, 140, 156, 188, 99, 65, 69, 76, 16, 97, 109, 131, 251, 129, 144, 172, 24, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 131, 147, 175, 232, 140, 157, 188, 43, 0, 0, 0, 0, 100, 112, 134, 211, 126, 141, 169, 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 72, 78, 88, 26, 48, 52, 57, 60, 135, 150, 178, 254, 108, 121, 145, 83, 105, 118, 142, 76, 106, 119, 143, 201, 118, 133, 159, 122, 117, 129, 152, 25, 168, 176, 190, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 118, 128, 145, 3, 104, 117, 140, 92, 114, 127, 152, 180, 131, 147, 177, 237, 133, 149, 178, 249, 38, 42, 50, 222, 137, 152, 180, 249, 126, 142, 170, 182, 114, 128, 154, 182, 104, 117, 140, 227, 95, 107, 128, 238, 83, 93, 112, 248, 84, 95, 113, 239, 104, 117, 141, 180, 115, 129, 155, 93, 127, 140, 165, 4, + 98, 109, 130, 153, 109, 123, 147, 254, 145, 163, 195, 153, 138, 154, 182, 56, 115, 123, 138, 5, 92, 99, 109, 35, 134, 149, 177, 230, 0, 0, 0, 0, 0, 0, 0, 0, 120, 133, 159, 143, 135, 151, 181, 115, 86, 89, 93, 5, 41, 45, 51, 54, 40, 45, 53, 150, 107, 120, 144, 254, 122, 137, 164, 154, + 51, 57, 66, 147, 83, 93, 112, 255, 108, 121, 145, 159, 113, 126, 151, 62, 123, 136, 159, 8, 87, 93, 103, 35, 125, 141, 169, 230, 0, 0, 0, 0, 0, 0, 0, 0, 129, 143, 169, 143, 140, 156, 184, 115, 134, 147, 172, 8, 124, 138, 165, 60, 124, 139, 167, 155, 131, 147, 177, 255, 131, 147, 176, 153, + 64, 68, 73, 2, 36, 39, 45, 86, 41, 46, 54, 173, 60, 67, 80, 232, 75, 84, 101, 251, 89, 100, 120, 228, 105, 118, 142, 250, 110, 123, 148, 187, 118, 132, 158, 187, 126, 141, 169, 229, 134, 149, 177, 239, 136, 152, 179, 250, 136, 152, 181, 234, 139, 156, 186, 175, 130, 145, 173, 90, 124, 134, 151, 3, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 71, 74, 79, 19, 60, 64, 73, 50, 92, 103, 124, 254, 86, 95, 111, 84, 90, 100, 117, 76, 126, 141, 168, 201, 113, 126, 150, 119, 99, 105, 117, 19, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93, 105, 125, 231, 135, 151, 181, 46, 0, 0, 0, 0, 137, 154, 184, 212, 123, 137, 164, 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 74, 83, 98, 191, 133, 149, 179, 102, 111, 121, 139, 17, 134, 150, 180, 252, 126, 140, 166, 23, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 43, 48, 57, 132, 121, 136, 164, 197, 121, 135, 161, 115, 130, 146, 175, 221, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 43, 47, 52, 46, 87, 98, 118, 254, 126, 142, 170, 254, 124, 139, 166, 135, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 51, 57, 67, 118, 115, 128, 152, 170, 127, 140, 164, 17, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; + + Ihandle* image = IupImageRGBA(16, 16, imgdata); + return image; +} + +static unsigned char img_bits1[] = +{ + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1 +,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,1 +,1,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,1,1 +,1,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,1,1,1 +,1,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,1,1,1,1 +,1,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,1,1,1,1,1 +,1,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,1,1,1,1,1,1 +,1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,1,1,1,1,1,1,1 +,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2 +,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2 +,2,2,2,0,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2 +,2,2,2,0,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2 +,2,2,2,0,2,0,2,0,2,2,0,2,2,2,0,0,0,2,2,2,0,0,2,0,2,2,0,0,0,2,2,2 +,2,2,2,0,2,0,0,2,0,0,2,0,2,0,2,2,2,0,2,0,2,2,0,0,2,0,2,2,2,0,2,2 +,2,2,2,0,2,0,2,2,0,2,2,0,2,2,2,2,2,0,2,0,2,2,2,0,2,0,2,2,2,0,2,2 +,2,2,2,0,2,0,2,2,0,2,2,0,2,2,0,0,0,0,2,0,2,2,2,0,2,0,0,0,0,0,2,2 +,2,2,2,0,2,0,2,2,0,2,2,0,2,0,2,2,2,0,2,0,2,2,2,0,2,0,2,2,2,2,2,2 +,2,2,2,0,2,0,2,2,0,2,2,0,2,0,2,2,2,0,2,0,2,2,0,0,2,0,2,2,2,0,2,2 +,2,2,2,0,2,0,2,2,0,2,2,0,2,2,0,0,0,0,2,2,0,0,2,0,2,2,0,0,0,2,2,2 +,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,0,2,2,2,2,2,2,2,2 +,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,0,2,2,2,0,2,2,2,2,2,2,2,2 +,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,0,0,0,2,2,2,2,2,2,2,2,2 +,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2 +,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2 +,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,1,1,1,1,1,1,1,1,1,1 +,1,1,1,1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,1,1,1,1,1,1,1,1,1,1,1 +,1,1,1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,1,1,1,1,1,1,1,1,1,1,1,1 +,1,1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,1,1,1,1,1,1,1,1,1,1,1,1,1 +,1,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1 +,1,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1 +,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1 +,2,2,2,2,2,2,2,2,2,2,2,2,2,2,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1 +}; + +static unsigned char img_bits2[] = +{ + 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,2 +,2,2,2,2,2,2,2,2,2,2,2,2,2,2,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,2,2 +,2,2,2,2,2,2,2,2,2,2,2,2,2,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,2,2,2 +,2,2,2,2,2,2,2,2,2,2,2,2,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,2,2,2,2 +,2,2,2,2,2,2,2,2,2,2,2,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,2,2,2,2,2 +,2,2,2,2,2,2,2,2,2,2,3,3,3,3,1,1,3,3,3,3,3,3,3,3,3,3,2,2,2,2,2,2 +,2,2,2,2,2,2,2,2,2,3,3,3,3,3,1,1,3,3,3,3,3,3,3,3,3,2,2,2,2,2,2,2 +,2,2,2,2,2,2,2,2,3,3,3,3,3,3,1,1,3,3,3,3,3,3,3,3,2,2,2,2,2,2,2,2 +,3,3,3,3,3,3,3,3,3,3,3,3,3,3,1,1,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3 +,3,3,3,3,3,3,3,3,3,3,3,3,3,3,1,1,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3 +,3,3,3,0,3,3,3,3,3,3,3,3,3,3,1,1,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3 +,3,3,3,0,3,3,3,3,3,3,3,3,3,3,1,1,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3 +,3,3,3,0,3,0,3,0,3,3,0,3,3,3,1,1,0,3,3,3,0,0,3,0,3,3,0,0,0,3,3,3 +,3,3,3,0,3,0,0,3,0,0,3,0,3,0,1,1,3,0,3,0,3,3,0,0,3,0,3,3,3,0,3,3 +,3,3,3,0,3,0,3,3,0,3,3,0,3,3,1,1,3,0,3,0,3,3,3,0,3,0,3,3,3,0,3,3 +,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1 +,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1 +,3,3,3,0,3,0,3,3,0,3,3,0,3,0,1,1,3,0,3,0,3,3,0,0,3,0,3,3,3,0,3,3 +,3,3,3,0,3,0,3,3,0,3,3,0,3,3,1,1,0,0,3,3,0,0,3,0,3,3,0,0,0,3,3,3 +,3,3,3,3,3,3,3,3,3,3,3,3,3,3,1,1,3,3,3,3,3,3,3,0,3,3,3,3,3,3,3,3 +,3,3,3,3,3,3,3,3,3,3,3,3,3,3,1,1,3,3,3,0,3,3,3,0,3,3,3,3,3,3,3,3 +,3,3,3,3,3,3,3,3,3,3,3,3,3,3,1,1,3,3,3,3,0,0,0,3,3,3,3,3,3,3,3,3 +,3,3,3,3,3,3,3,3,3,3,3,3,3,3,1,1,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3 +,3,3,3,3,3,3,3,3,3,3,3,3,3,3,1,1,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3 +,2,2,2,2,2,2,2,3,3,3,3,3,3,3,1,1,3,3,3,3,3,2,2,2,2,2,2,2,2,2,2,2 +,2,2,2,2,2,2,3,3,3,3,3,3,3,3,1,1,3,3,3,3,2,2,2,2,2,2,2,2,2,2,2,2 +,2,2,2,2,2,3,3,3,3,3,3,3,3,3,3,3,3,3,3,2,2,2,2,2,2,2,2,2,2,2,2,2 +,2,2,2,2,3,3,3,3,3,3,3,3,3,3,3,3,3,3,2,2,2,2,2,2,2,2,2,2,2,2,2,2 +,2,2,2,3,3,3,3,3,3,3,3,3,3,3,3,3,3,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2 +,2,2,3,3,3,3,3,3,3,3,3,3,3,3,3,3,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2 +,2,3,3,3,3,3,3,3,3,3,3,3,3,3,3,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2 +,3,3,3,3,3,3,3,3,3,3,3,3,3,3,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2 +}; + +static int copydata_cb(Ihandle* ih, char* value, int size) +{ + printf("COPYDATA(%s, %d)\n", value, size); + return IUP_DEFAULT; +} + +static int valuechanged_cb(Ihandle *ih) +{ + printf("VALUECHANGED_CB(%s)=%s\n", IupGetClassName(ih), IupGetAttribute(ih, "VALUE")); + return IUP_DEFAULT; +} + +static int getfocus_cb(Ihandle *ih) +{ + printf("GETFOCUS_CB(%s)\n", IupGetClassName(ih)); + return IUP_DEFAULT; +} + +static int killfocus_cb(Ihandle *ih) +{ + printf("KILLFOCUS_CB(%s)\n", IupGetClassName(ih)); + return IUP_DEFAULT; +} + +static int leavewindow_cb(Ihandle *ih) +{ + printf("LEAVEWINDOW_CB(%s)\n", IupGetClassName(ih)); + return IUP_DEFAULT; +} + +static int enterwindow_cb(Ihandle *ih) +{ + printf("ENTERWINDOW_CB(%s)\n", IupGetClassName(ih)); + return IUP_DEFAULT; +} + +/* Internal SDK function */ +char *iupKeyCodeToName(int code); + +static int k_any(Ihandle *ih, int c) +{ + if (iup_isprint(c)) + printf("K_ANY(%s, %d = %s \'%c\')\n", IupGetClassName(ih), c, iupKeyCodeToName(c), (char)c); + else + printf("K_ANY(%s, %d = %s)\n", IupGetClassName(ih), c, iupKeyCodeToName(c)); + if (c==K_r) { IupRecordInput("inputtest.iup", IUP_RECTEXT); return IUP_IGNORE; } //IUP_RECBINARY, IUP_RECTEXT + if (c==K_s) { IupRecordInput(NULL, 0); IupPlayInput(NULL); return IUP_IGNORE; } + if (c==K_p) { IupPlayInput("inputtest.iup"); return IUP_IGNORE; } + return IUP_CONTINUE; +} + +static int help_cb(Ihandle* ih) +{ + printf("HELP_CB(%s)\n", IupGetClassName(ih)); + return IUP_DEFAULT; +} + +static void show_menu(Ihandle* ih) +{ + int x, y; + + Ihandle* menu_file = IupMenu( + IupSetAttributes(IupItem("Item with Image", "item_cb"), "IMAGE=image_tec"), + IupSetAttributes(IupItem("Toggle using VALUE", NULL), "VALUE=ON, KEY=K_V"), + IupSetAttributes(IupItem("Auto &Toggle", "item_cb"), "AUTOTOGGLE=YES, VALUE=OFF, IMAGE=image_test, IMPRESS=image_test_pressed"), + IupSeparator(), + IupItem("E&xit (Close)", NULL), + NULL); + Ihandle* menu = IupMenu( + IupSetAttributes(IupSubmenu("Submenu", menu_file), "KEY=K_S, IMAGE=image_tec"), + IupItem("Item", "item_cb"), + IupSetAttributes(IupItem("Item", "item_cb"), "VALUE=ON"), + IupSetAttributes(IupItem("Item", "item_cb"), "KEY=K_I, IMAGE=image_tec"), + NULL); + + x = IupGetInt(ih, "X"); + y = IupGetInt(ih, "Y") + IupGetInt2(ih, "RASTERSIZE"); + + IupPopup(menu, x, y); + IupDestroy(menu); +} + +static int action1_cb(Ihandle* ih) +{ +// IupSetAttribute(IupGetDialog(ih), "BACKGROUND", "255 128 128"); + show_menu(ih); + return IUP_DEFAULT; +} + +static int action2_cb(Ihandle* ih) +{ + IupSetAttribute(IupGetDialog(ih), "BGCOLOR", "0 128 0"); + return IUP_DEFAULT; +} + +static int action3_cb(Ihandle* ih) +{ + printf("ACTION3\n"); +// IupSetAttribute(IupGetChild(IupGetDialog(ih), 0), "BGCOLOR", "128 0 0"); + return IUP_DEFAULT; +} + +static Ihandle* set_callbacks(Ihandle* ih) +{ + IupSetCallback(ih, "VALUECHANGED_CB", (Icallback)valuechanged_cb); + +// IupSetCallback(ih, "GETFOCUS_CB", (Icallback)getfocus_cb); +// IupSetCallback(ih, "KILLFOCUS_CB", (Icallback)killfocus_cb); + +// IupSetCallback(ih, "ENTERWINDOW_CB", (Icallback)enterwindow_cb); +// IupSetCallback(ih, "LEAVEWINDOW_CB", (Icallback)leavewindow_cb); + + IupSetCallback(ih, "K_ANY", (Icallback)k_any); +// IupSetCallback(ih, "HELP_CB", (Icallback)help_cb); + + return ih; +} + +int btn_big_button_cb(Ihandle *self, int button, int press) +{ + printf("BUTTON_CB(button=%c, press=%d)\n", button, press); + return IUP_DEFAULT; +} + +static void globalkeypress_cb(int code, int pressed) +{ + printf("GLOBALKEYPRESS_CB(code=%s, pressed=%d)\n", iupKeyCodeToName(code), pressed); +} + +static void globalmotion_cb(int x, int y, char* status) +{ + printf("GLOBALMOTION_CB(x=%d, y=%d, status=%s)\n", x, y, status); +} + +static void globalbutton_cb(int button, int pressed, int x, int y, char* status) +{ + printf("GLOBALBUTTON_CB(button=%c, pressed=%d, x=%d, y=%d, status=%s)\n", (char)button, pressed, x, y, status); +} + +static void globalwheel_cb(float delta,int x, int y, char* status) +{ + printf("GLOBALWHEEL_CB(delta=%g, x=%d, y=%d, status=%s)\n", delta, x, y, status); +} + +int btn_image_button_cb( Ihandle *self,int b, int e ) +{ + /* If the left button changed its state... */ + if( b == IUP_BUTTON1 ) + { + /* IUP handles */ + Ihandle* text; + + /* Recovers "text" handle */ + text = IupGetHandle( "text" ); + + /* If the button was pressed... */ + if(e == 1) + { + /* Sets text's value */ + IupSetAttribute( text, "VALUE", "Red button pressed" ); + } + /* else the button was released */ + else + { + /* Sets text's value */ + IupSetAttribute( text, "VALUE", "Red button released" ); + } + } + + /* Executed function successfully */ + return IUP_DEFAULT; +} + +void SampleTest(void) +{ + Ihandle *mnu, *_hbox_1, *_cnv_1, *_vbox_1, *dlg, *img, + *_frm_1, *_frm_2, *_frm_3, *_frm_4, *_frm_5, *pbar, *val, *tabs, + *_list_1, *_list_2, *_list_3, *_text_1, *_ml_1, *tree; + + //img = IupImage(32,32, img_bits1); + //IupSetHandle ("img1", img); + //IupSetAttribute (img, "0", "0 0 0"); + //IupSetAttribute (img, "1", "BGCOLOR"); + //IupSetAttribute (img, "2", "255 0 0"); + + img = load_image_Tecgraf(); + IupSetHandle ("img1", img); + + img = IupImage(32,32, img_bits2); + IupSetHandle ("img2", img); + IupSetAttribute (img, "0", "0 0 0"); + IupSetAttribute (img, "1", "0 255 0"); + IupSetAttribute (img, "2", "BGCOLOR"); + IupSetAttribute (img, "3", "255 0 0"); + + mnu = IupMenu( + IupSubmenu("IupSubmenu 1", IupMenu( + IupSetAttributes(IupItem("IupItem 1 Checked", NULL), "VALUE=ON"), + IupSeparator(), + + IupSetAttributes(IupItem("IupItem 2 Disabled", NULL), "VALUE=ON"), + NULL)), + IupItem("IupItem 3", NULL), + IupItem("IupItem 4", NULL), + NULL); + IupSetHandle("mnu",mnu); + + _frm_1 = IupFrame( + IupVbox( + set_callbacks(IupSetAttributes(IupButton("Button Text", NULL), "PADDING=5x5")), + IupSetCallbacks(set_callbacks(IupSetAttributes(IupButton("Text", NULL), "IMAGE=img1, PADDING=5x5")),"ACTION", action1_cb, NULL), + IupSetCallbacks(set_callbacks(IupSetAttributes(IupButton(NULL, NULL), "IMAGE=img1")),"ACTION", action2_cb, NULL), + IupSetCallbacks(set_callbacks(IupSetAttributes(IupButton("Text", NULL), "IMAGE=img1")),"BUTTON_CB", (Icallback)btn_big_button_cb, NULL), + IupSetCallbacks(set_callbacks(IupSetAttributes(IupButton("", NULL), "IMAGE=img1,IMPRESS=img2")),"ACTION", action3_cb, NULL), + IupSetCallbacks(set_callbacks(IupSetAttributes(IupButton(NULL, NULL), "BGCOLOR=\"255 0 128\", SIZE=20x10")),"ACTION", action3_cb, NULL), + NULL)); + IupSetAttribute(_frm_1,"TITLE","IupButton"); + + _frm_2 = IupFrame( + IupVbox( + IupLabel("Label Text"), + IupSetAttributes(IupLabel(NULL), "SEPARATOR=HORIZONTAL, MAXSIZE=150, NAME=SAMP_SEP"), + IupSetAttributes(IupLabel(NULL), "IMAGE=img1"), + NULL)); + IupSetAttribute(_frm_2,"TITLE","IupLabel"); + + _frm_3 = IupFrame( + IupVbox( + set_callbacks(IupSetAttributes(IupToggle("Toggle Text", NULL), "VALUE=ON")), + set_callbacks(IupSetAttributes(IupToggle(NULL, NULL), "VALUE=ON,IMAGE=img1,IMPRESS=img2")), + set_callbacks(IupSetAttributes(IupToggle(NULL, NULL), "VALUE=ON,IMAGE=img1")), + IupSetAttributes(IupFrame(IupRadio(IupVbox( + set_callbacks(IupToggle("Toggle Text", NULL)), + set_callbacks(IupToggle("Toggle Text", NULL)), + NULL))), "TITLE=IupRadio"), + NULL)); + IupSetAttribute(_frm_3,"TITLE","IupToggle"); + + _text_1 = IupText( NULL); + IupSetAttribute(_text_1,"VALUE","Single Line Text"); + IupSetAttribute(_text_1,"SIZE","80x"); + + _ml_1 = IupMultiLine( NULL); + IupSetAttribute(_ml_1,"VALUE","Multiline Text\nSecond Line\nThird Line"); + IupSetAttribute(_ml_1,"EXPAND","YES"); + IupSetAttribute(_ml_1,"SIZE","80x40"); + + _frm_4 = IupFrame(IupVbox( + set_callbacks(_text_1), + set_callbacks(_ml_1), + NULL)); + IupSetAttribute(_frm_4,"TITLE","IupText"); + + _list_1 = IupList( NULL); +// IupSetAttribute(_list_1,"EXPAND","YES"); + IupSetAttribute(_list_1,"VALUE","1"); + IupSetAttribute(_list_1,"1","Item 1 Text"); + IupSetAttribute(_list_1,"2","Item 2 Text"); + IupSetAttribute(_list_1,"3","Item 3 Text"); + IupSetAttribute(_list_1,"TIP","List 1"); + + _list_2 = IupList( NULL); + IupSetAttribute(_list_2,"DROPDOWN","YES"); +// IupSetAttribute(_list_2,"EXPAND","YES"); + IupSetAttribute(_list_2,"VALUE","2"); + IupSetAttribute(_list_2,"1","Item 1 Text"); + IupSetAttribute(_list_2,"2","Item 2 Text"); + IupSetAttribute(_list_2,"3","Item 3 Text"); + IupSetAttribute(_list_2,"TIP","List 2"); + + _list_3 = IupList( NULL); + IupSetAttribute(_list_3,"EDITBOX","YES"); +// IupSetAttribute(_list_3,"EXPAND","YES"); + IupSetAttribute(_list_3,"VALUE","3"); + IupSetAttribute(_list_3,"1","Item 1 Text"); + IupSetAttribute(_list_3,"2","Item 2 Text"); + IupSetAttribute(_list_3,"3","Item 3 Text"); + IupSetAttribute(_list_3,"TIP","List 3"); + + _frm_5 = IupFrame(IupVbox( + set_callbacks(_list_1), + set_callbacks(_list_2), + set_callbacks(_list_3), + NULL)); + IupSetAttribute(_frm_5,"TITLE","IupList"); + + _hbox_1 = IupHbox( + _frm_1, + _frm_2, + _frm_3, + _frm_4, + _frm_5, + NULL); + + val = IupVal(NULL); + set_callbacks(val); + + pbar = IupProgressBar(); + IupSetAttribute(pbar, "VALUE", "0.5"); + set_callbacks(pbar); + + tabs = IupTabs(IupVbox(IupLabel(""), NULL), IupVbox(IupFill(), NULL), IupVbox(IupFill(), NULL), NULL); + IupSetAttribute(tabs,"TABTITLE0","Tab Title 0"); + IupSetAttribute(tabs,"TABTITLE1","Tab Title 1"); + IupSetAttributeHandle(tabs,"TABIMAGE1", load_image_LogoTecgraf()); + IupSetAttribute(tabs,"TABTITLE2","Tab Title 2"); + IupSetAttribute(tabs,"RASTERSIZE","300x50"); +// IupSetAttribute(tabs,"TABPADDING","5x5"); + set_callbacks(tabs); + + tree = IupTree(); + IupSetAttribute(tree, "SHOWRENAME", "YES"); + IupSetAttribute(tree,"RASTERSIZE","100x150"); + set_callbacks(tree); + + _cnv_1 = IupCanvas(NULL); + IupSetAttribute(_cnv_1,"BGCOLOR","128 255 0"); + IupSetAttribute(_cnv_1,"SCROLLBAR","YES"); + IupSetAttribute(_cnv_1,"EXPAND","HORIZONTAL"); + IupSetAttribute(_cnv_1,"RASTERSIZE","x100"); +// IupSetAttribute(_cnv_1,"CANFOCUS","NO"); + set_callbacks(_cnv_1); + + _vbox_1 = IupVbox( + _hbox_1, + IupHbox(IupSetAttributes(IupFrame(IupHbox(val, NULL)), "TITLE=IupVal"), + IupSetAttributes(IupFrame(IupHbox(pbar, NULL)), "TITLE=IupProgressBar"), + IupSetAttributes(IupFrame(IupHbox(tabs, NULL)), "TITLE=IupTabs"), + NULL), + IupHbox(IupSetAttributes(IupFrame(IupHbox(_cnv_1, NULL)), "TITLE=IupCanvas"), + IupSetAttributes(IupFrame(IupHbox(tree, NULL)), "TITLE=IupTree"), + NULL), + NULL); + IupSetAttribute(_vbox_1,"MARGIN","5x5"); + IupSetAttribute(_vbox_1,"GAP","5"); + + dlg = IupDialog(_vbox_1); + IupSetHandle("dlg",dlg); + IupSetAttribute(dlg,"MENU","mnu"); + IupSetAttribute(dlg,"TITLE","Iup Sample Dialog Title"); +// IupSetAttribute(dlg,"COMPOSITED","YES"); /* Windows Only */ +// IupSetAttribute(dlg, "OPACITY", "192"); + +// IupSetAttribute(dlg, "BGCOLOR", "173 177 194"); // Motif BGCOLOR for documentation +// IupSetAttribute(_vbox_1, "BGCOLOR", "92 92 255"); +// IupSetAttribute(dlg, "BGCOLOR", "92 92 255"); +// IupSetAttribute(dlg, "BACKGROUND", "200 10 80"); + + //IupSetGlobal("DLGBGCOLOR", "92 92 255"); + //IupSetGlobal("TXTFGCOLOR", "255 92 92"); + //IupSetGlobal("TXTBGCOLOR", "92 92 255"); + +// IupSetAttribute(dlg, "FONT", "Helvetica, 24"); +// IupSetAttribute(dlg, "FONT", "-*-helvetica-*-r-*-*-18-*-*-*-*-*-*-*"); + +// IupSetAttribute(box, "FGCOLOR", "255 0 0"); + +// IupSetAttribute(dlg,"RASTERSIZE","1000x800"); + + IupSetCallback(dlg, "COPYDATA_CB", (Icallback)copydata_cb); + + //IupSetGlobal("INPUTCALLBACKS", "Yes"); + //IupSetFunction("GLOBALKEYPRESS_CB", (Icallback)globalkeypress_cb); + //IupSetFunction("GLOBALMOTION_CB", (Icallback)globalmotion_cb); + IupSetFunction("GLOBALBUTTON_CB", (Icallback)globalbutton_cb); + //IupSetFunction("GLOBALWHEEL_CB", (Icallback)globalwheel_cb); + + IupMap(dlg); + + IupSetAttribute(tree, "TITLE0", "Figures"); + IupSetAttribute(tree, "ADDLEAF0", "Other"); /* new id=1 */ + IupSetAttribute(tree, "ADDBRANCH1", "triangle"); /* new id=2 */ + IupSetAttribute(tree, "ADDLEAF2", "equilateral"); /* ... */ + IupSetAttribute(tree, "ADDLEAF3", "isoceles"); + IupSetAttribute(tree, "ADDLEAF4", "scalenus"); + + IupShow(dlg); + +// IupSetAttribute(dlg,"RASTERSIZE", NULL); +} + +static int dropcheck_cb(Ihandle *self, int lin, int col) +{ + if (lin == 3 && col == 1) + return IUP_DEFAULT; + if (lin == 4 && col == 4) + return IUP_CONTINUE; + return IUP_IGNORE; +} + +static Ihandle* create_matrix(void) +{ + Ihandle *img; + + Ihandle* mat = IupMatrix(NULL); + + img = IupImage(32,32, img_bits2); + IupSetHandle ("img2", img); + + IupSetAttribute(mat, "NUMLIN", "20"); + IupSetAttribute(mat, "NUMCOL", "8"); + + IupSetAttribute(mat, "1:1", "5.6\n3.33"); + IupSetAttribute(mat, "2:1", "2.2"); + IupSetAttribute(mat, "3:2", "Very Very Very Very Very Large Text"); + IupSetAttribute(mat, "1:2", "4.5"); + if (IupGetInt(NULL, "UTF8MODE")) + IupSetAttribute(mat, "2:2", "(çãõáóé)"); + else + IupSetAttribute(mat, "2:2", "(çãõáóé)"); + IupSetAttribute(mat, "3:1", "3.4"); + IupSetAttribute(mat, "3:3", "Font Test"); + IupSetAttribute(mat,"SORTSIGN2","DOWN"); + IupSetAttribute(mat,"RESIZEMATRIX", "YES"); + IupSetAttribute(mat, "FONT3:3", "Helvetica, 24"); + IupSetAttribute(mat, "MASK*:3", "[a-zA-Z][0-9a-zA-Z_]*"); + + IupSetAttribute(mat, "TYPE4:1", "COLOR"); + IupSetAttribute(mat, "4:1", "255 0 128"); + + IupSetAttribute(mat, "TYPE4:2", "FILL"); + IupSetAttribute(mat, "4:2", "60"); + IupSetAttribute(mat, "SHOWFILLVALUE", "Yes"); + + { + Ihandle* image = IupImageRGBA(TEST_IMAGE_SIZE, TEST_IMAGE_SIZE, image_data_32 ); + IupSetAttribute(mat, "TYPE4:3", "IMAGE"); + IupSetAttributeHandle(mat, "4:3", image); + } + IupSetAttribute(mat, "TOGGLECENTERED", "Yes"); + + IupSetAttribute(mat,"MARKMODE","CELL"); + IupSetAttribute(mat,"MARKMULTIPLE","YES"); + IupSetAttribute(mat,"FRAMEVERTCOLOR1:2","BGCOLOR"); + IupSetAttribute(mat,"FRAMEHORIZCOLOR1:2","0 0 255"); + IupSetAttribute(mat,"FRAMEHORIZCOLOR1:3","0 255 0"); + IupSetAttribute(mat,"FRAMEVERTCOLOR2:2","255 255 0"); + IupSetAttribute(mat,"FRAMEVERTCOLOR*:4","0 255 0"); + IupSetAttribute(mat,"FRAMEVERTCOLOR*:5","BGCOLOR"); + IupSetAttribute(mat, "20:8", "The End"); + IupSetAttribute(mat, "NUMCOL_VISIBLE", "3"); + IupSetAttribute(mat, "NUMLIN_VISIBLE", "5"); + IupSetAttribute(mat, "FRAMEBORDER", "Yes"); + IupSetCallback(mat, "DROPCHECK_CB", (Icallback)dropcheck_cb); + IupSetCallback(mat,"DROP_CB",(Icallback)drop); + IupSetCallback(mat,"TOGGLEVALUE_CB",(Icallback)togglevalue_cb); + return mat; +} + + +void MatrixTest(void) +{ + Ihandle* dlg, *box, *mat; + + box = IupVbox(mat = create_matrix(), NULL); + IupSetAttribute(box, "MARGIN", "10x10"); +// IupSetAttribute(box, "FONT", "Arial, 7"); + + dlg = IupDialog(box); + IupSetAttribute(dlg, "TITLE", "IupMatrix Simple Test"); + IupShowXY(dlg, IUP_CENTER, IUP_CENTER); + +} + +#ifndef BIG_TEST +int main(int argc, char* argv[]) +{ + IupOpen(&argc, &argv); + + IupSetGlobal("SINGLEINSTANCE", "Iup Sample"); /* must partially match dialog title so COPYDATA_CB can work */ + if (!IupGetGlobal("SINGLEINSTANCE")) + { + IupClose(); + return EXIT_SUCCESS; + } + + SampleTest(); + + MatrixTest(); + + IupMainLoop(); + + IupClose(); + + return EXIT_SUCCESS; +} +#endif ADDED iup-test/sample.scm Index: iup-test/sample.scm ================================================================== --- /dev/null +++ iup-test/sample.scm @@ -0,0 +1,9 @@ +(use iup) + +(show (dialog (vbox (button "PUSHME" + button-cb: (lambda (obj . param) + (print "obj: " obj " param: " param)) + action: (lambda (obj) + (print "obj: " obj)))))) + +(main-loop) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -377,14 +377,16 @@ start-seconds))))) (kill-tries 0)) ;; (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area) ;; (tests:set-full-meta-info test-id run-id (calc-minutes) work-area) (tests:set-full-meta-info #f test-id run-id (calc-minutes) work-area 10) + (let loop ((minutes (calc-minutes)) (cpu-load (alist-ref 'adj-core-load (common:get-normalized-cpu-load #f))) (disk-free (get-df (current-directory))) (last-sync (current-seconds))) + (common:telemetry-log "zombie" (conc "launch:monitor-job - top of loop encountered at "(current-seconds)" with last-sync="last-sync)) (let* ((over-time (> (current-seconds) (+ last-sync update-period))) (new-cpu-load (let* ((load (alist-ref 'adj-core-load (common:get-normalized-cpu-load #f))) (delta (abs (- load cpu-load)))) (if (> delta 0.1) ;; don't bother updating with small changes load @@ -395,24 +397,43 @@ (delta (abs (- df disk-free)))) (if (and (> df 0) (> (/ delta df) 0.1)) ;; (> delta 200) ;; ignore changes under 200 Meg df #f))) - (do-sync (or new-cpu-load new-disk-free over-time))) + (do-sync (or new-cpu-load new-disk-free over-time)) + + (test-info (rmt:get-test-info-by-id run-id test-id)) + (state (db:test-get-state test-info)) + (status (db:test-get-status test-info)) + (kill-reason "no kill reason specified") + (kill-job? #f)) + (common:telemetry-log "zombie" (conc "launch:monitor-job - decision time encountered at "(current-seconds)" with last-sync="last-sync" do-sync="do-sync" over-time="over-time" update-period="update-period)) + (cond + ((test-get-kill-request run-id test-id) + (set! kill-reason "KILLING TEST since received kill request (KILLREQ)") + (set! kill-job? #t)) + ((and runtlim (> (- (current-seconds) start-seconds) runtlim)) + (set! kill-reason (conc "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" (- (current-seconds) start-seconds) " seconds, limit=" runtlim)) + (set! kill-job? #t)) + ((equal? status "DEAD") + (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f) + (rmt:set-state-status-and-roll-up-items run-id test-id 'foo "RUNNING" "n/a" "was marked dead; really still running.") + ;;(set! kill-reason "KILLING TEST because it was marked as DEAD by launch:handle-zombie-tests (might indicate really overloaded server or else overzealous setup.deadtime)") ;; MARK RUNNING + (set! kill-job? #f))) + (debug:print 4 *default-log-port* "cpu: " new-cpu-load " disk: " new-disk-free " last-sync: " last-sync " do-sync: " do-sync) - (set! kill-job? (or (test-get-kill-request run-id test-id) ;; run-id test-name itemdat)) - (and runtlim (let* ((run-seconds (- (current-seconds) start-seconds)) - (time-exceeded (> run-seconds runtlim))) - (if time-exceeded - (begin - (debug:print-info 0 *default-log-port* "KILLING TEST DUE TO TIME LIMIT EXCEEDED! Runtime=" run-seconds " seconds, limit=" runtlim) - #t) - #f))))) - (if do-sync - (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f)) + (launch:handle-zombie-tests run-id) + (when do-sync + ;;(with-output-to-file (conc (getenv "MT_TEST_RUN_DIR") "/last-loadinfo.log" #:append) + ;; (lambda () (pp (list (current-seconds) new-cpu-load new-disk-free (calc-minutes))))) + (common:telemetry-log "zombie" (conc "launch:monitor-job - dosync started at "(current-seconds))) + (tests:update-central-meta-info run-id test-id new-cpu-load new-disk-free (calc-minutes) #f #f) + (common:telemetry-log "zombie" (conc "launch:monitor-job - dosync finished at "(current-seconds)))) + (if kill-job? (begin + (debug:print-info 0 *default-log-port* "proceeding to kill test: "kill-reason) (mutex-lock! m) ;; NOTE: The pid can change as different steps are run. Do we need handshaking between this ;; section and the runit section? Or add a loop that tries three times with a 1/4 second ;; between tries? (let* ((pid1 (launch:einf-pid exit-info)) ;; (vector-ref exit-info 0)) @@ -442,14 +463,15 @@ #f (process-signal pid-num signal/kill))) (process:get-sub-pids pid)))) ;; (debug:print-info 0 *default-log-port* "not killing process " pid " as it is not alive")))) pids) - (tests:test-set-status! run-id test-id "KILLED" "KILLED" (args:get-arg "-m") #f)) + ;; BB: question to Matt -- does the tests:test-state-status! encompass rollup to toplevel? If not, should it? + (tests:test-set-status! run-id test-id "KILLED" "KILLED" (conc (args:get-arg "-m")" "kill-reason) #f)) ;; BB ADDED kill-reason -- confirm OK with Matt (begin (debug:print-error 0 *default-log-port* "Nothing to kill, pid1=" pid1 ", pid2=" pid2) - (tests:test-set-status! run-id test-id "KILLED" "FAILED TO KILL" (args:get-arg "-m") #f) + (tests:test-set-status! run-id test-id "KILLED" "FAILED TO KILL" (conc (args:get-arg "-m")" "kill-reason) #f) ;; BB ADDED kill-reason -- confirm OK with Matt ))) (mutex-unlock! m) ;; no point in sticking around. Exit now. (exit))) (if (hash-table-ref/default misc-flags 'keep-going #f) @@ -573,18 +595,19 @@ (let ((sighand (lambda (signum) ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting (if (eq? signum signal/stop) (debug:print-error 0 *default-log-port* "attempt to STOP process. Exiting.")) (set! *time-to-exit* #t) - (print "Received signal " signum ", cleaning up before exit. Please wait...") + (print "Received signal " signum ", cleaning up before exit (set this test to COMPLETED/ABORT) . Please wait...") (let ((th1 (make-thread (lambda () - (rmt:test-set-state-status run-id test-id "INCOMPLETE" "KILLED" #f) + (print "set test to COMPLETED/ABORT begin.") + (rmt:test-set-state-status run-id test-id "COMPLETED" "ABORT" "received kill signal") + (print "set test to COMPLETED/ABORT complete.") (print "Killed by signal " signum ". Exiting") - (thread-sleep! 1) (exit 1)))) (th2 (make-thread (lambda () - (thread-sleep! 2) + (thread-sleep! 20) (debug:print 0 *default-log-port* "Done") (exit 4))))) (thread-start! th2) (thread-start! th1) (thread-join! th2))))) @@ -605,27 +628,28 @@ (cond ;; -mrw- I'm removing KILLREQ from this list so that a test in KILLREQ state is treated as a "do not run" flag. ((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun (debug:print 0 *default-log-port* "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request") ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a") - (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f) + + (rmt:general-call 'set-test-start-time #f test-id) + (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f) ) ;; prime it for running ((member (db:test-get-state test-info) '("RUNNING" "REMOTEHOSTSTART")) (if (process:alive-on-host? test-host test-pid) (debug:print-error 0 *default-log-port* "test state is " (db:test-get-state test-info) " and process " test-pid " is still running on host " test-host ", cannot proceed") - ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a") - (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f) - )) + (exit))) ((not (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ"))) ;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a") + (rmt:general-call 'set-test-start-time #f test-id) (rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f) ) (else ;; (member (db:test-get-state test-info) '("REMOVING" "REMOTEHOSTSTART" "RUNNING" "KILLREQ")) (debug:print-error 0 *default-log-port* "test state is " (db:test-get-state test-info) ", cannot proceed") (exit)))) - (debug:print 2 *default-log-port* "Exectuing " test-name " (id: " test-id ") on " (get-host-name)) + (debug:print 2 *default-log-port* "Executing " test-name " (id: " test-id ") on " (get-host-name)) (set! keys (rmt:get-keys)) ;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process ;; one of these is defunct/redundant ... (if (not (launch:setup force-reread: #t)) (begin @@ -1333,10 +1357,32 @@ (begin (debug:print-error 0 *default-log-port* "Failed to create work area at " test-path " with link at " lnktarget ", remaining attempts " remtries) ;; (create-work-area run-id run-info keyvals test-id test-src-path disk-path testname itemdat remtries: (- remtries 1))) (list #f #f))))) + + +(define (launch:handle-zombie-tests run-id) + (let* ((key (conc "zombiescan-runid-"run-id)) + (now (current-seconds)) + (threshold (- (current-seconds) (* 2 (or (configf:lookup-number *configdat* "setup" "deadtime") 120)))) + (val (rmt:get-var key)) + (do-scan? + (cond + ((not val) + #t) + ((< val threshold) + #t) + (else #f)))) + (when do-scan? + (debug:print 1 *default-log-port* "INFO: search and mark zombie tests") + (rmt:set-var key (current-seconds)) + (rmt:find-and-mark-incomplete run-id #f)))) + + + + ;; 1. look though disks list for disk with most space ;; 2. create run dir on disk, path name is meaningful ;; 3. create link from run dir to megatest runs area ;; 4. remotely run the test on allocated host Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -18,6 +18,6 @@ ;; Always use two or four digit decimal ;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.6514) +(define megatest-version 1.6525) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -110,10 +110,12 @@ Launching and managing runs -run : run all tests or as specified by -testpatt -remove-runs : remove the data for a run, requires -runname and -testpatt Optionally use :state and :status, use -keep-records to remove only the run data. + -kill-runs : kill existing run(s) (all incomplete tests killed) + -kill-rerun : kill an existing run (all incomplete tests killed and run is rerun) -set-state-status X,Y : set state to X and status to Y, requires controls per -remove-runs -rerun FAIL,WARN... : force re-run for tests with specificed status(s) -rerun-clean : set all tests not COMPLETED+PASS,WARN,WAIVED to NOT_STARTED,n/a and then run the specified testpatt with -preclean -rerun-all : set all tests to NOT_STARTED,n/a and run with -preclean @@ -291,10 +293,11 @@ "-set-toplog" "-runstep" "-logpro" "-m" "-rerun" + "-days" "-rename-run" "-to" ;; values and messages ":category" @@ -307,10 +310,11 @@ "-start-dir" "-run-patt" "-target-patt" "-contour" "-area-tag" + "-area" "-server" "-transport" "-port" "-extract-ods" "-pathmod" @@ -339,10 +343,11 @@ "-run-id" "-ping" "-refdb2dat" "-o" "-log" + "-sync-log" "-since" "-fields" "-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state "-sort" "-target-db" @@ -403,10 +408,12 @@ "-test-paths" ;; get path(s) to a test, ordered by youngest first "-runall" ;; run all tests, respects -testpatt, defaults to % "-run" ;; alias for -runall "-remove-runs" + "-kill-runs" + "-kill-rerun" "-keep-records" ;; use with -remove-runs to remove only the run data "-rebuild-db" "-cleanup-db" "-rollup" "-update-meta" @@ -571,11 +578,11 @@ (process:children #f)) (original-exit exit-code))))) ;; for some switches always print the command to stderr ;; -(if (args:any? "-run" "-runall" "-remove-runs" "-set-state-status") +(if (args:any? "-run" "-runall" "-remove-runs" "-set-state-status" "-kill-runs" "-kill-rerun") (debug:print 0 *default-log-port* (string-intersperse (argv) " "))) ;; some switches imply homehost. Exit here if not on homehost ;; (let ((homehost-required (list "-cleanup-db" "-server"))) @@ -1038,11 +1045,11 @@ (exit 1)) ((not (or (args:get-arg ":runname") (args:get-arg "-runname"))) (debug:print-error 0 *default-log-port* "Missing required parameter for " action ", you must specify the run name pattern with -runname patt") (exit 2)) - ((not (args:get-arg "-testpatt")) + ((not (or (args:get-arg "-testpatt") (eq? action 'kill-runs))) (debug:print-error 0 *default-log-port* "Missing required parameter for " action ", you must specify the test pattern with -testpatt") (exit 3)) (else (if (not (car *configinfo*)) (begin @@ -1059,10 +1066,46 @@ state: (common:args-get-state) status: (common:args-get-status) new-state-status: (args:get-arg "-set-state-status") mode: mode))) (set! *didsomething* #t))))) + +(if (args:get-arg "-kill-runs") + (general-run-call + "-kill-runs" + "kill runs" + (lambda (target runname keys keyvals) + (operate-on 'kill-runs mode: #f) + ))) + +(if (args:get-arg "-kill-rerun") + (let* ((target-patt (args:get-arg "-target")) + (runname-patt (args:get-arg "-runname"))) + (cond ((not target-patt) + (debug:print-error 0 *default-log-port* "Missing target, must specify target for -kill-rerun with -target ") + (exit 1)) + ((not runname-patt) + (debug:print-error 0 *default-log-port* "Missing runname, must specify runname for -kill-rerun with -runname ") + (exit 1)) + ((string-search "[ ,%]" target-patt) + (debug:print-error 0 *default-log-port* "Invalid target ["target-patt"], must specify exact target (no wildcards) for -kill-rerun with -target ") + (exit 1)) + ((string-search "[ ,%]" runname-patt) + (debug:print-error 0 *default-log-port* "Invalid runname ["runname-patt"], must specify exact runname (no wildcards) for -kill-rerun with -runname ") + (exit 1)) + (else + (general-run-call + "-kill-runs" + "kill runs" + (lambda (target runname keys keyvals) + (operate-on 'kill-runs mode: #f) + )) + + (thread-sleep! 15)) + ;; fall thru and let "-run" loop fire + ))) + (if (args:get-arg "-remove-runs") (general-run-call "-remove-runs" "remove runs" @@ -1622,35 +1665,39 @@ ;; run all tests are are Not COMPLETED and PASS or CHECK (if (or (args:get-arg "-runall") (args:get-arg "-run") (args:get-arg "-rerun-clean") (args:get-arg "-rerun-all") - (args:get-arg "-runtests")) + (args:get-arg "-runtests") + (args:get-arg "-kill-rerun")) (let ((need-clean (or (args:get-arg "-rerun-clean") (args:get-arg "-rerun-all")))) (general-run-call "-runall" "run all tests" (lambda (target runname keys keyvals) - (if (args:get-arg "-rerun-clean") ;; first set states/statuses correct + (if (or (args:get-arg "-kill-rerun") (args:get-arg "-rerun-clean")) ;; first set states/statuses correct + ;; For rerun-clean do we or do we not support the testpatt? (let ((states (or (configf:lookup *configdat* "validvalues" "cleanrerun-states") "KILLREQ,KILLED,UNKNOWN,INCOMPLETE,STUCK,NOT_STARTED")) (statuses (or (configf:lookup *configdat* "validvalues" "cleanrerun-statuses") "FAIL,INCOMPLETE,ABORT,CHECK,DEAD,PREQ_FAIL,PREQ_DISCARDED"))) (hash-table-set! args:arg-hash "-preclean" #t) (runs:operate-on 'set-state-status target (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) - "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") + ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") + (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") state: states ;; status: statuses new-state-status: "NOT_STARTED,n/a") (runs:clean-cache target runname *toppath*) (runs:operate-on 'set-state-status target (common:args-get-runname) ;; (or (args:get-arg "-runname")(args:get-arg ":runname")) - "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") + ;; "%" ;; (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") + (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt") ;; state: states status: statuses new-state-status: "NOT_STARTED,n/a"))) ;; RERUN ALL (if (args:get-arg "-rerun-all") ;; first set states/statuses correct @@ -2247,14 +2294,24 @@ ;; 'new2old ) (set! *didsomething* #t))) (if (args:get-arg "-sync-to-megatest.db") - (let ((res (db:multi-db-sync - (db:setup #f) - 'new2old))) - (print "Synced " res " records to megatest.db") + (let* ((dbstruct (db:setup #f)) + (tmpdbpth (cdr (dbr:dbstruct-tmpdb dbstruct))) + (lockfile (conc tmpdbpth ".lock")) + (locked (common:simple-file-lock lockfile)) + (res (if locked + (db:multi-db-sync + dbstruct + 'new2old) + #f))) + (if res + (begin + (common:simple-file-release-lock lockfile) + (print "Synced " res " records to megatest.db")) + (print "Skipping sync, there is a sync in progress.")) (set! *didsomething* #t))) (if (args:get-arg "-sync-to") (let ((toppath (launch:setup))) (tasks:sync-to-postgres *configdat* (args:get-arg "-sync-to")) Index: mt-pg.sql ================================================================== --- mt-pg.sql +++ mt-pg.sql @@ -42,13 +42,17 @@ DROP TABLE IF EXISTS sessions; DROP TABLE IF EXISTS tags; DROP TABLE IF EXISTS users; DROP TABLE IF EXISTS webviews; DROP TABLE IF EXISTS area_tags; - DROP TABLE IF EXISTS users_webviews; - +DROP TABLE IF EXISTS base_paths; +DROP TABLE IF EXISTS area_owners; +DROP TABLE IF EXISTS shared_user_views; +DROP TABLE IF EXISTS cctrl_info; +DROP TABLE IF EXISTS cctrl_config; +DROP TABLE IF EXISTS platforms; CREATE TABLE IF NOT EXISTS session_vars ( id SERIAL PRIMARY KEY, session_id INTEGER, @@ -78,11 +82,11 @@ tag_id INTEGER DEFAULT 0, area_id INTEGER DEFAULT 0, CONSTRAINT areatagconstraint UNIQUE (tag_id, area_id)); CREATE VIEW area_tag_view as -select a.id as aid, t.id as tid,area_name,tag_name from areas as a inner join area_tags as at on at.area_id = a.id +select a.id as aid, t.id as tid,area_name,tag_name,area_path from areas as a inner join area_tags as at on at.area_id = a.id inner join tags as t on t.id = at.tag_id ; INSERT INTO areas (id,area_name,area_path) VALUES (0,'local','.'); CREATE TABLE IF NOT EXISTS ttype ( @@ -102,10 +106,18 @@ fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, last_update INTEGER DEFAULT extract(epoch from now()), area_id INTEGER DEFAULT 0, CONSTRAINT runsconstraint UNIQUE (target,ttype_id,run_name, area_id)); + +create Table if not exists change_triggers ( + id SERIAL PRIMARY KEY, + target TEXT NOT NULL, + area TEXT NOT NULL, + iteration INTEGER NOT NULL, + iteration_timestamp TIMESTAMP WITHOUT TIME ZONE DEFAULT now(), + reason TEXT Not null); CREATE TABLE IF NOT EXISTS run_stats ( id SERIAL PRIMARY KEY, run_id INTEGER, state TEXT, @@ -254,10 +266,11 @@ id SERIAL PRIMARY KEY , username TEXT NOT NULL, fullname TEXT NOT NULL, email TEXT NOT NULL, default_view TEXT default '', + is_admin boolean default 'f', deleted INTEGER default 0 ); CREATE TABLE IF NOT EXISTS base_paths( id SERIAL PRIMARY KEY , @@ -288,22 +301,24 @@ ttype_id INTEGER DEFAULT 0, view_specifics TEXT , col TEXT NOT NULL, row TEXT NOT NULL, public INTEGER DEFAULT 0, + search_patt TEXT default '.*', deleted INTEGER default 0 ); CREATE TABLE IF NOT EXISTS users_webviews( id SERIAL PRIMARY KEY , - user_id INTEGER NOT NULL, - webview_id INTEGER NOT NULL, - deleted INTEGER default 0, - searchpattern TEXT Default '', - web_page TEXT Default '', + user_id INTEGER NOT NULL, + webview_id INTEGER NOT NULL, + deleted INTEGER default 0, + searchpattern TEXT Default '', + web_page TEXT Default '', + is_default boolean default 'f', other_search_data TEXT Default '' ); CREATE TABLE IF NOT EXISTS cctrl_info( id SERIAL PRIMARY KEY , @@ -314,18 +329,18 @@ ); CREATE TABLE IF NOT EXISTS cctrl_config( id SERIAL PRIMARY KEY , area_type Text, + metadata text default '', cmd TEXT ); CREATE TABLE IF NOT EXISTS platforms( id SERIAL PRIMARY KEY , name Text ); - -- TRUNCATE archive_blocks, archive_allocations, extradat, metadat, -- access_log, tests, test_steps, test_data, test_rundat, archives, runs, -- run_stats, test_meta, tasks_queue, archive_disks; Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -140,10 +140,12 @@ Run management: run : initiate or resume a run, already completed and in-progress tests are not affected. rerun-clean : clean and rerun all not completed pass/fail tests rerun-all : clean and rerun entire run + kill-run : kill all tests in run + kill-rerun : kill all tests in run and restart non-completed tests remove : remove runs set-ss : set state/status archive : compress and move test data to archive disk kill : stop tests or entire runs db : database utilities @@ -247,10 +249,12 @@ ;; alist to map actions to old megatest commands (define *action-keys* '((run . "-run") (rerun-clean . "-rerun-clean") (rerun-all . "-rerun-all") + (kill-run . "-kill-runs") + (kill-rerun . "-kill-rerun") (sync . "") (archive . "-archive") (set-ss . "-set-state-status") (remove . "-remove-runs"))) @@ -571,10 +575,52 @@ "timer thread"))) (thread-start! th1) (thread-start! th2) (thread-join! th1) res)))) + +(define (open-send-receive-nn host-port msg attrib #!key (timeout 3) ) ;; default timeout is 3 seconds + (let ((req (nn-socket 'req)) + (uri (conc "tcp://" host-port)) + (res #f) + (contacts (alist-ref 'contact attrib)) + (mode (alist-ref 'mode attrib))) + (handle-exceptions + exn + (let ((emsg ((condition-property-accessor 'exn 'message) exn))) + ;; Send notification + (print "ERROR: Failed to connect / send to " uri " message was \"" emsg "\"" ) + (if (equal? mode "production") + (begin + (print " Sending email to contacts : " contacts ) + (let ((email-body (mtut:stml->string (s:body + (s:p (conc "We could not send messages to the server on " uri "." "Please check if the listner is running. It is possible that the host is overloaded due to which it may take too long to respond. \n Contact your system adminstrator if server load is high." (s:br)" Thank You ") ))))) + (sendmail (string-join (string-split contacts ";" )) (conc "[Listner Error] Filed to connect to listner on " uri) email-body use_html: #t))) + (print " mode : " mode " Not sending any emails" )) + #f) + (nn-connect req uri) + (print "Connected to the server " ) + (nn-send req msg) + (print "Request Sent") + ;; receive code here + ;;(print (nn-recv req)) + (let* ((th1 (make-thread (lambda () + (let ((resp (nn-recv req))) + (nn-close req) + (print resp) + (set! res (if (equal? resp "ok") + #t + #f)))) + "recv thread")) + (th2 (make-thread (lambda () + (thread-sleep! timeout) + (thread-terminate! th1)) + "timer thread"))) + (thread-start! th1) + (thread-start! th2) + (thread-join! th1) + res)))) ;;====================================================================== ;; Runs ;;====================================================================== @@ -836,13 +882,19 @@ (apply max (map cdr synctimes)))) ) (let ((delta (lambda (x) (round (/ (- (current-seconds) x) 60))))) - (print "runkey: " runkey ", ruletype: " ruletype ", action: " action ", last-run: " last-run " time since; last-run: " (delta last-run) ", last-sync: " (delta last-sync))) + (if (args:get-arg "-target") + (if (string= (args:get-arg "-target") runkey) + (begin (print "runkey: " runkey ", ruletype: " ruletype ", action: " action ", last-run: " last-run " time since; last-run: " (delta last-run) ", last-sync: " (delta last-sync)) + (print "val-alist=" val-alist " runtrans=" runtrans)) + (if #f (print "skipping: " runkey))) + (begin (print "runkey: " runkey ", ruletype: " ruletype ", action: " action ", last-run: " last-run " time since; last-run: " (delta last-run) ", last-sync: " (delta last-sync)) + (print "val-alist=" val-alist " runtrans=" runtrans)) + )) - (print "val-alist=" val-alist " runtrans=" runtrans) ;; look in runstarts for matching runs by target and contour ;; get the timestamp for when that run started and pass it ;; to the rule logic here where "ruletype" will be applied ;; if it comes back "changed" then proceed to register the runs @@ -952,20 +1004,32 @@ (lambda (cmd) ;;(print "cmd: " cmd) ;;(print "Areas: " all-areas) (for-each (lambda (area) - (if (area-allowed? area "area-needs-to-be-run" runkey contour #f) ;; is this area to be handled (from areas=a,b,c OR using areafn=abcfn and *area-checks* ...) +;Add code to check whether area is valid + (if + (if (args:get-arg "-target") + (if (string= (args:get-arg "-target") runkey) (area-allowed? area "area-needs-to-be-run" runkey contour #f) #f) + (area-allowed? area "area-needs-to-be-run" runkey contour #f)) (let* ((script (car cmd)) (params (cdr cmd)) (cmd (conc script " " contour " " area " " runkey " " std-runname " " action " " params)) (res (handle-exceptions exn #f (print "Running " cmd) - (with-input-from-pipe cmd read-lines)))) + (with-input-from-pipe cmd read-lines))) + (cval (or (configf:lookup mtconf "contours" contour) "")) + (cval-alist (common:val->alist cval)) ;; BEWARE ... NOT the same val-alist as above! + ;;(areas (val-alist->areas cval-alist)) + (selector (alist-ref 'selector cval-alist)) + (mode-tag (and selector (string-split-fields "/" selector #:infix))) + (mode-patt (and mode-tag (if (eq? (length mode-tag) 2)(cadr mode-tag) #f))) + (tag-expr (and mode-tag (if (null? mode-tag) #f (car mode-tag)))) + ) (if (and res (not (null? res))) (let* ((parts (string-split (car res))) ;; (rem-lines (cdr res)) (num-parts (length parts)) (last-change (string->number (if (> num-parts 0)(car parts) "abc"))) ;; force no run if not a number returned @@ -1006,12 +1070,12 @@ 0 (apply max (map cdr starttimes)))) ;; (last-run 9) ;; I think we can do a more valid calculation for this based on the run started packets for this particular area and target (reason "Area-script-triggered") - (mode-patt #f) - (tag-expr #f) + ;;(mode-patt #f) + ;;(tag-expr #f) (sched #f) (message (if (null? rem-lines) cmd (string-intersperse rem-lines "-"))) (need-run (> last-change last-run))) @@ -1030,10 +1094,11 @@ (targets (map-targets mtconf aval-alist runkey area contour))) (pp targets) (for-each (lambda (target) (create-run-pkt mtconf action area runkey target new-runname mode-patt tag-expr pktsdir reason contour sched dbdest append runtrans)) targets) + ;; Add filter for targets ;;(create-run-pkt mtconf action area runkey target runname ;; pktsdir reason contour dbdest append ;; runtrans) (print "key-msg: " key-msg) @@ -1040,11 +1105,11 @@ ;;(push-run-spec torun contour ;; (if optional ;; we need to be able to differentiate same contour, different behavior. ;; (conc runkey ":" optional) ;; NOTE: NOT COMPLETELY IMPLEMENTED. DO NOT USE ;; runkey) ;; key-msg) - ))))))) all-areas) + ))))))) (filter (lambda (x) (if (not (args:get-arg "-area")) #t (if (string= x (args:get-arg "-area")) #t #f))) all-areas)) ) val-alist)) ;; iterate over the param split by ;\s* ;; fossil scm based triggers ;; ((fossil) @@ -1382,11 +1447,11 @@ (set! *default-log-port* oup) ))) (if *action* (case (string->symbol *action*) - ((run remove rerun rerun-clean rerun-all set-ss archive kill list) + ((run remove rerun rerun-clean rerun-all set-ss archive kill list kill-run kill-rerun) (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir"))) (mtconf (car mtconfdat)) (area (args:get-arg "-area")) ;; look up the area to dispatch to from [areas] section (areasec (if area (configf:lookup mtconf "areas" area) #f)) (areadat (if areasec (common:val->alist areasec) #f)) @@ -1516,11 +1581,119 @@ (open-send-close-nn host-port msg attrib timeout: time-out ))) listeners)) (begin (debug:print-error 0 *default-log-port* "Could not Identify executing user. Will not send any message") (exit 1)))))) + ((tquery) + (if (null? remargs) + (print "ERROR: missing data to send to trigger listeners") + (let* ((msg (car remargs)) + (mtconfdat (simple-setup (args:get-arg "-start-dir"))) + (mtconf (car mtconfdat)) + (time-out (if (args:get-arg "-time-out") + (string->number (args:get-arg "-time-out")) + 5)) + (listeners (configf:get-section mtconf "listeners")) + (user-info (user-information (current-user-id))) + (prev-seen (make-hash-table))) ;; catch duplicates + (if user-info + (begin + (for-each + (lambda (listener) + (let ((host-port (car listener)) + (attrib (val->alist (cadr listener)))) + (if (and (equal? msg "time-to-die") (not (can-user-kill-listner user-info attrib))) + (begin + (debug:print-error 0 *default-log-port* "User " (car user-info) " is not allowed to send message '" msg"'") + (exit 1))) + (print "sending " msg " to " host-port ) + (open-send-receive-nn host-port msg attrib timeout: time-out ))) + listeners)) + (begin + (debug:print-error 0 *default-log-port* "Could not Identify executing user. Will not send any message") + (exit 1)))))) + + ((tquerylisten) + (if (null? remargs) + (print "ERROR: useage for tlisten is \"mtutil tlisten portnum\"") + (let ((portnum (string->number (car remargs)))) + + (if (not portnum) + (print "ERROR: the portnumber parameter must be a number, you gave: " (car remargs)) + (begin + (if (not (is-port-in-use portnum)) + (let* ((rep (start-nn-server portnum)) + (mtconfdat (simple-setup (args:get-arg "-start-dir"))) + (mtconf (car mtconfdat)) + (contact (configf:lookup mtconf "listener" "owner")) + (script (configf:lookup mtconf "listener" "script"))) + (print "Listening on port " portnum " for messages.") + (set-signal-handler! signal/int (lambda (signum) + (set! *time-to-exit* #t) + (debug:print-error 0 *default-log-port* "Received signal " signum " sending email befor exiting !!") + (let ((email-body (mtut:stml->string (s:body + (s:p (conc "Received signal " signum ". Lister has been terminated on host " (get-environment-variable "HOST") ". ")))))) + (sendmail contact "Listner has been terminated." email-body use_html: #t)) + (exit))) + (set-signal-handler! signal/term (lambda (signum) + (set! *time-to-exit* #t) + (debug:print-error 0 *default-log-port* "Received signal " signum " sending email befor exiting !!") + (let ((email-body (mtut:stml->string (s:body + (s:p (conc "Received signal " signum ". Lister has been terminated on host " (get-environment-variable "HOST") ". ")))))) + (sendmail contact "Listner has been terminated." email-body use_html: #t)) + (exit))) + + ;(set-signal-handler! signal/term special-signal-handler) + + (let loop ((instr (nn-recv rep))) + ;;(nn-send rep "3.9") + (with-input-from-pipe (conc "/usr/bin/uptime | cut -d':' -f4 | awk '{print $1}' | cut -d',' -f1") + (lambda() + (let loop ((inl (read-line))) + (if (not (eof-object? inl)) + (begin + ;;(print "fdk73: " inl ":") + ;;(set! current-list-ciaf (append! current-list-ciaf (list (string-substitute "\\s+$" "" inl)))) + (nn-send rep inl) + (loop(read-line))) + )) + + ) + ) + ;;(print (isys "/usr/bin/uptime" foreach-stdout-thunk: foreach-stdout)) + (let ((ctime (date->string (current-date)))) + (if (equal? instr "time-to-die") + (begin + (debug:print 0 *default-log-port* ctime " received '" instr "'. Time to sucide." ) + (let ((pid (current-process-id))) + (debug:print 0 *default-log-port* "Killing current process (pid=" pid ")") + (system (conc "kill " pid)))) + (begin + (debug:print 0 *default-log-port* ctime " received " instr ) + ;(nn-send rep "ok") + (if (not (equal? instr "ping")) + (begin + (debug:print 0 *default-log-port* ctime " running \"" script " " instr "\"") + ;(system (conc script " '" instr "'")) + (process-run script (list instr )) + (debug:print 0 *default-log-port* ctime " done" )) + (begin + (if (not (equal? instr "load")) + (print "Checking load") + + ) + ) + + ) + + ))) + (loop (nn-recv rep)))) + (print "ERROR: Port " portnum " already in use. Try another port"))))))) + + + ((tlisten) (if (null? remargs) (print "ERROR: useage for tlisten is \"mtutil tlisten portnum\"") (let ((portnum (string->number (car remargs)))) @@ -1559,18 +1732,28 @@ (debug:print 0 *default-log-port* ctime " received '" instr "'. Time to sucide." ) (let ((pid (current-process-id))) (debug:print 0 *default-log-port* "Killing current process (pid=" pid ")") (system (conc "kill " pid)))) (begin - (debug:print 0 *default-log-port* ctime " received " instr ) - ;(nn-send rep "ok") + (debug:print 0 *default-log-port* ctime " received " instr ) + ;(nn-send rep "ok") (if (not (equal? instr "ping")) (begin (debug:print 0 *default-log-port* ctime " running \"" script " " instr "\"") - ;(system (conc script " '" instr "'")) - (process-run script (list (conc "'" instr "'"))) - (debug:print 0 *default-log-port* ctime " done" )))))) + (system (conc script " '" instr "' &")) + ;(process-run script (list instr )) + (debug:print 0 *default-log-port* ctime " done" )) + (begin + (if (not (equal? instr "load")) + (print "Checking load") + + ) + ) + + ) + + ))) (loop (nn-recv rep)))) (print "ERROR: Port " portnum " already in use. Try another port"))))))) ((gather) ;; gather all area db's into /tmp/$USER_megatest/alldbs (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir"))) (mtconf (car mtconfdat)) Index: process.scm ================================================================== --- process.scm +++ process.scm @@ -74,14 +74,14 @@ (set! result (append result (list errstr))))) (if (not (eof-object? curr)) (loop (read-line fh) (append result (list curr))) (begin - ;(close-input-port fh) - ;(close-input-port fhe) - ;(close-output-port fho) (let-values (((anotherpid normalexit? exitstatus) (process-wait pid))) + (close-input-port fh) + (close-input-port fhe) + (close-output-port fho) (list result (if normalexit? exitstatus -1)))))))) (define (process:cmd-run-proc-each-line cmd proc . params) ;; (print "Called with cmd=" cmd ", proc=" proc ", params=" params) (handle-exceptions Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -55,10 +55,15 @@ ;; RA => e.g. usage (rmt:send-receive 'get-var #f (list varname)) ;; (define (rmt:send-receive cmd rid params #!key (attemptnum 1)(area-dat #f)) ;; start attemptnum at 1 so the modulo below works as expected + (common:telemetry-log (conc "rmt:"(->string cmd)) + payload: `((rid . ,rid) + (params . ,params))) + + ;;DOT digraph megatest_state_status { ;;DOT ranksep=0; ;;DOT // rankdir=LR; ;;DOT node [shape="box"]; ;;DOT "rmt:send-receive" -> MUTEXLOCK; @@ -465,10 +470,13 @@ ;; NOT COMPLETED (define (rmt:runtests user run-id testpatt params) (rmt:send-receive 'runtests run-id testpatt)) +(define (rmt:get-run-record-ids target run keynames test-patt) + (rmt:send-receive 'get-run-record-ids #f (list target run keynames test-patt))) + (define (rmt:get-changed-record-ids since-time) (rmt:send-receive 'get-changed-record-ids #f (list since-time)) ) ;;====================================================================== ;; T E S T M E T A Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -1,6 +1,5 @@ - ;; Copyright 2006-2016, Matthew Welland. ;; ;; This file is part of Megatest. ;; ;; Megatest is free software: you can redistribute it and/or modify @@ -451,10 +450,17 @@ ;; register this run in monitor.db (rmt:tasks-add "run-tests" user target runname test-patts task-key) ;; params) (rmt:tasks-set-state-given-param-key task-key "running") + (common:telemetry-log "run-tests" + payload: + `( (target . ,target) + (run-name . ,runname) + (test-patts . ,test-patts) ) ) + + ;; Now generate all the tests lists (set! all-tests-registry (tests:get-all)) ;; hash of testname => path-to-test (set! all-test-names (hash-table-keys all-tests-registry)) ;; filter first for allowed-tests (from -tagexpr) then for test-patts. (set! test-names (tests:filter-test-names @@ -530,10 +536,13 @@ (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc (debug:print-info 4 *default-log-port* "\n\ntestpatt elaboration loop => hed="hed " tal="tal" test-patts="test-patts" test-names="test-names) (change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening. (setenv "MT_TEST_NAME" hed) ;; (let*-values (((waitons waitors config) (tests:get-waitons hed all-tests-registry)) + + ;; NOTE: Have the config - can extract [waitons] section + ((hed-mode) (let ((m (config-lookup config "requirements" "mode"))) (if m (map string->symbol (string-split m)) '(normal)))) ((hed-itemized-waiton) ;; are items in hed waiting on items of waiton? (not (null? (lset-intersection eq? hed-mode '(itemmatch itemwait))))) @@ -1396,16 +1405,35 @@ (tconfig (tests:testqueue-get-testconfig test-record)) (jobgroup (config-lookup tconfig "test_meta" "jobgroup")) (testmode (let ((m (config-lookup tconfig "requirements" "mode"))) (if m (map string->symbol (string-split m)) '(normal)))) (itemmaps (tests:get-itemmaps tconfig)) ;; (configf:lookup tconfig "requirements" "itemmap")) - (waitons (tests:testqueue-get-waitons test-record)) (priority (tests:testqueue-get-priority test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) ;; itemdat can be a string, list or #f (items (tests:testqueue-get-items test-record)) (item-path (item-list->path itemdat)) (tfullname (db:test-make-full-name test-name item-path)) + ;; these are hard coded item-item waits test/item-path => test/item-path2 ... + (extra-waits (let* ((section (configf:get-section (tests:testqueue-get-testconfig test-record) "waitons")) + (myextra (alist-ref tfullname section equal?))) + (if myextra + (let ((extras (string-split (car myextra)))) + (if (runs:lownoise (conc tfullname "extra-waitons" tfullname) 60) + (debug:print-info 0 *default-log-port* "HAVE EXTRA WAITONS for test " tfullname ": " myextra)) + (for-each + (lambda (extra) + ;; (debug:print 0 *default-log-port* "FYI: extra = " extra " reruns = " reruns) + (let ((basetestname (car (string-split extra "/")))) + #;(if (not (member extra tal)) + (set! reruns (append tal (list extra)))) + (if (not (member basetestname tal)) + (set! reruns (append tal (list basetestname)))) + )) + extras) + extras) + '()))) + (waitons (delete-duplicates (append (tests:testqueue-get-waitons test-record) extra-waits) equal?)) (newtal (append tal (list hed))) (regfull (>= (length reg) reglen)) (num-running (rmt:get-count-tests-running-for-run-id run-id)) (testdat (make-runs:testdat hed: hed @@ -1981,11 +2009,14 @@ " " (time->string (seconds->local-time (simple-run-event_time run)) "WW%V.%u %H:%M:%S") " " (if remove "REMOVE" ""))) ((remove-runs) (if remove (system (conc precmd " megatest -remove-runs -target " target " -runname " (simple-run-runname run) " -testpatt %")))) ((archive) - (if remove (system (conc precmd " megatest -archive save-remove -target " target " -runname " (simple-run-runname run) " -testpatt %")))))) + (if remove (system (conc precmd " megatest -archive save-remove -target " target " -runname " (simple-run-runname run) " -testpatt %")))) + ((kill-runs) + (if remove (system (conc precmd " megatest -kill-runs -target " target " -runname " (simple-run-runname run) " -testpatt %")))) + )) actions)))) sorted))) ;; (print "Sorted: " (map simple-run-event_time sorted)) ;; (print "Remove: " (map simple-run-event_time to-remove)))) (hash-table-keys runs-ht)) @@ -2023,11 +2054,11 @@ (state-status (if (string? new-state-status) (string-split new-state-status ",") '(#f #f))) (rp-mutex (make-mutex)) (bup-mutex (make-mutex)) (keep-records (args:get-arg "-keep-records"))) ;; used in conjunction with -remove-runs to keep the records, TODO: consolidate this with "mode". - (let* ((write-access-actions '(remove-runs set-state-status archive run-wait)) + (let* ((write-access-actions '(remove-runs set-state-status archive run-wait kill-runs)) (dbfile (conc *toppath* "/megatest.db")) (readonly-mode (not (file-write-access? dbfile)))) (when (and readonly-mode (member action write-access-actions)) (debug:print-error 0 *default-log-port* "megatest.db is readonly. Cannot proceed with action ["action"] in which write-access isrequired .") @@ -2060,16 +2091,19 @@ (worker-thread #f)) (debug:print-info 4 *default-log-port* "runs:operate-on run=" run ", header=" header) (if (not (null? tests)) (begin (case action + ((kill-runs) + (tasks:kill-runner target run-name "%") + (debug:print 1 *default-log-port* "Killing tests for run: " runkey " " (db:get-value-by-header run header "runname")) + ) ((remove-runs) ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) ;; seek and kill in flight -runtests with % as testpatt here ;; (if (equal? testpatt "%") (tasks:kill-runner target run-name testpatt) - ;; (debug:print 0 *default-log-port* "not attempting to kill any run launcher processes as testpatt is " testpatt)) (debug:print 1 *default-log-port* "Removing tests for run: " runkey " " (db:get-value-by-header run header "runname"))) ((set-state-status) ;; (if (tasks:need-server run-id)(tasks:start-and-wait-for-server tdbdat run-id 10)) (debug:print 1 *default-log-port* "Modifying state and staus for tests for run: " runkey " " (db:get-value-by-header run header "runname"))) @@ -2128,14 +2162,16 @@ ;; (rmt:sdb-qry 'getid (db:test-get-rundir new-test-dat)) ;; ) ;; run dir is from the link tree (has-subrun (and (subrun:subrun-test-initialized? run-dir) (not (subrun:subrun-removed? run-dir)))) (test-state (db:test-get-state new-test-dat)) + (test-status (db:test-get-status new-test-dat)) (test-fulln (db:test-get-fullname new-test-dat)) (uname (db:test-get-uname new-test-dat)) (toplevel-with-children (and (db:test-get-is-toplevel test) (> (rmt:test-toplevel-num-items run-id test-name) 0)))) + (case action ((remove-runs) ;; if the test is a toplevel-with-children issue an error and do not remove (cond (toplevel-with-children @@ -2173,11 +2209,11 @@ (if (< (- now last-visit) 1.0) (thread-sleep! 1.0)) (hash-table-set! backgrounded-remove-last-visit test-fulln (current-seconds)) ;; send to back of line, loop (let ((newtal (append tal (list test)))) - (loop (car newtal)(cdr newtal))) + (loop (car newtal)(cdr newtal))) ) ((done) ;; drop this one; if remaining, loop, else finish (hash-table-set! backgrounded-remove-last-visit test-fulln (current-seconds)) (let ((subrun-remove-succeeded (hash-table-ref/default backgrounded-remove-result test-fulln 'exception))) @@ -2230,10 +2266,38 @@ (begin (runs:remove-test-directory new-test-dat mode) ;; 'remove-all) (if (not (null? tal)) (loop (car tal)(cdr tal))))))) (rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id))) + ((kill-runs) + ;; RUNNING -> KILLREQ + ;; LAUNCHED,RUNNING,REMOTEHOSTSTART -> NOT STARTED + (cond + ((and has-subrun (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ"))) + (common:send-thunk-to-background-thread + (lambda () + (let* ((subrun-remove-succeeded + (subrun:kill-subrun run-dir keep-records))) + #t))) + (if (not (null? tal)) + (loop (car tal)(cdr tal))) + ) + ((member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ")) + (debug:print 1 *default-log-port* "INFO: issuing killreq to test "test-fulln) + (mt:test-set-state-status-by-id run-id (db:test-get-id test) "KILLREQ" "n/a" #f) + (if (not (null? tal)) + (loop (car tal)(cdr tal)))) + ((and (member test-status '("PREQ_FAIL" "PREQ_DISCARDED" "BLOCKED" "ZERO_ITEMS" "KEEP_TRYING" "TEN_STRIKES" "TIMED_OUT"))) + (rmt:set-state-status-and-roll-up-items run-id (db:test-get-id test) 'foo "NOT_STARTED" "n/a" (conc "kill-run moved from "test-state":"test-status" to NOT_STARTED:n/a")) + ;;(mt:test-set-state-status-by-id run-id (db:test-get-id test) "NOT_STARTED" "n/a" (conc "kill-run moved from "test-state":"test-status" to NOT_STARTED:n/a")) + (if (not (null? tal)) + (loop (car tal)(cdr tal))) + ) + (else + (if (not (null? tal)) + (loop (car tal)(cdr tal))) + ))) ((set-state-status) (let* ((new-state (car state-status)) (new-status (cadr state-status)) (test-id (db:test-get-id test)) (test-run-dir (db:test-get-rundir new-test-dat)) ADDED serialize-env.scm Index: serialize-env.scm ================================================================== --- /dev/null +++ serialize-env.scm @@ -0,0 +1,9 @@ +(use z3) +(use base64) + +(let* ((env-str (with-output-to-string (lambda () (pp (get-environment-variables))))) + (zipped-env-str (z3:encode-buffer env-str)) + (b64-env-str (base64-encode zipped-env-str))) + (print b64-env-str)) + + Index: server.scm ================================================================== --- server.scm +++ server.scm @@ -481,140 +481,226 @@ (vector->list (hostinfo-addresses (hostname->hostinfo hostname)))) (string-intersperse (map number->string (u8vector->list (if res res (hostname->ip hostname)))) "."))) + +;; (define server:sync-lock-token "SERVER_SYNC_LOCK") +;; (define (server:release-sync-lock) +;; (db:no-sync-del! *no-sync-db* server:sync-lock-token)) +;; (define (server:have-sync-lock?) +;; (let* ((have-lock-pair (db:no-sync-get-lock *no-sync-db* server:sync-lock-token)) +;; (have-lock? (car have-lock-pair)) +;; (lock-time (cdr have-lock-pair)) +;; (lock-age (- (current-seconds) lock-time))) +;; (cond +;; (have-lock? #t) +;; ((>lock-age +;; (* 3 (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 180))) +;; (server:release-sync-lock) +;; (server:have-sync-lock?)) +;; (else #f)))) ;; moving this here as it needs access to db and cannot be in common. ;; (define (server:writable-watchdog dbstruct) - (thread-sleep! 0.05) ;; delay for startup - (let ((legacy-sync (common:run-sync?)) - (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300)) - (debug-mode (debug:debug-mode 1)) - (last-time (current-seconds)) - (no-sync-db (db:open-no-sync-db)) - (sync-duration 0) ;; run time of the sync in milliseconds - ;;(this-wd-num (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x))) - ) - (set! *no-sync-db* no-sync-db) ;; make the no sync db available to api calls - (debug:print-info 2 *default-log-port* "Periodic sync thread started.") - (debug:print-info 3 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id) );; " this-wd-num="this-wd-num) - (if (and legacy-sync (not *time-to-exit*)) - (let* (;;(dbstruct (db:setup)) - (mtdb (dbr:dbstruct-mtdb dbstruct)) - (mtpath (db:dbdat-get-path mtdb)) - (tmp-area (common:get-db-tmp-area)) - (start-file (conc tmp-area "/.start-sync")) - (end-file (conc tmp-area "/.end-sync"))) - (debug:print-info 0 *default-log-port* "Server running, periodic sync started.") - (let loop () - ;; sync for filesystem local db writes - ;; - (mutex-lock! *db-multi-sync-mutex*) - (let* ((need-sync (>= *db-last-access* *db-last-sync*)) ;; no sync since last write - (sync-in-progress *db-sync-in-progress*) - (min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 5)) - (should-sync (and (not *time-to-exit*) - (> (- (current-seconds) *db-last-sync*) min-intersync-delay))) ;; sync every five seconds minimum, deprecated logic, can probably be removed - (start-time (current-seconds)) - (cpu-load-adj (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f))) - (mt-mod-time (file-modification-time mtpath)) - (last-sync-start (if (common:file-exists? start-file) - (file-modification-time start-file) - 0)) - (last-sync-end (if (common:file-exists? end-file) - (file-modification-time end-file) - 10)) - (sync-period (+ 3 (* cpu-load-adj 30))) ;; as adjusted load increases increase the sync period - (recently-synced (and (< (- start-time mt-mod-time) sync-period) ;; not useful if sync didn't modify megatest.db! - (< mt-mod-time last-sync-start))) - (sync-done (<= last-sync-start last-sync-end)) - (sync-stale (> start-time (+ last-sync-start sync-stale-seconds))) - (will-sync (and (not *time-to-exit*) ;; do not start a sync if we are in the process of exiting - (or need-sync should-sync) - (or sync-done sync-stale) - (not sync-in-progress) - (not recently-synced)))) - (debug:print-info 13 *default-log-port* "WD writable-watchdog top of loop. need-sync="need-sync" sync-in-progress=" sync-in-progress - " should-sync="should-sync" start-time="start-time" mt-mod-time="mt-mod-time" recently-synced="recently-synced" will-sync="will-sync - " sync-done=" sync-done " sync-period=" sync-period) - (if (and (> sync-period 5) - (common:low-noise-print 30 "sync-period")) - (debug:print-info 0 *default-log-port* "Increased sync period due to long sync times, sync took: " sync-period " seconds.")) - ;; (if recently-synced (debug:print-info 0 *default-log-port* "Skipping sync due to recently-synced flag=" recently-synced)) - ;; (debug:print-info 0 *default-log-port* "need-sync: " need-sync " sync-in-progress: " sync-in-progress " should-sync: " should-sync " will-sync: " will-sync) - (if will-sync (set! *db-sync-in-progress* #t)) - (mutex-unlock! *db-multi-sync-mutex*) - (if will-sync - (let (;; (max-sync-duration (configf:lookup-number *configdat* "server" "max-sync-duration")) ;; KEEPING THIS AVAILABLE BUT SHOULD NOT USE, I'M PRETTY SURE IT DOES NOT WORK! - (sync-start (current-milliseconds))) - (with-output-to-file start-file (lambda ()(print (current-process-id)))) - - ;; put lock here - - ;; (if (or (not max-sync-duration) - ;; (< sync-duration max-sync-duration)) ;; NOTE: db:sync-to-megatest.db keeps track of time of last sync and syncs incrementally - (let ((res (db:sync-to-megatest.db dbstruct no-sync-db: no-sync-db))) ;; did we sync any data? If so need to set the db touched flag to keep the server alive - (set! sync-duration (- (current-milliseconds) sync-start)) - (if (> res 0) ;; some records were transferred, keep the db alive - (begin - (mutex-lock! *heartbeat-mutex*) - (set! *db-last-access* (current-seconds)) - (mutex-unlock! *heartbeat-mutex*) - (debug:print-info 0 *default-log-port* "sync called, " res " records transferred.")) - (debug:print-info 2 *default-log-port* "sync called but zero records transferred"))))) -;; ;; TODO: factor this next routine out into a function -;; (with-input-from-pipe ;; this should not block other threads but need to verify this -;; (conc "megatest -sync-to-megatest.db -m testsuite:" (common:get-area-name) ":" *toppath*) -;; (lambda () -;; (let loop ((inl (read-line)) -;; (res #f)) -;; (if (eof-object? inl) -;; (begin -;; (set! sync-duration (- (current-milliseconds) sync-start)) -;; (cond -;; ((not res) -;; (debug:print 0 *default-log-port* "ERROR: sync from /tmp db to megatest.db appears to have failed. Recommended that you stop your runs and run \"megatest -cleanup-db\"")) -;; ((> res 0) -;; (mutex-lock! *heartbeat-mutex*) -;; (set! *db-last-access* (current-seconds)) -;; (mutex-unlock! *heartbeat-mutex*)))) -;; (let ((num-synced (let ((matches (string-match "^Synced (\\d+).*$" inl))) -;; (if matches -;; (string->number (cadr matches)) -;; #f)))) -;; (loop (read-line) -;; (or num-synced res)))))))))) - (if will-sync - (begin - (mutex-lock! *db-multi-sync-mutex*) - (set! *db-sync-in-progress* #f) - (set! *db-last-sync* start-time) - (with-output-to-file end-file (lambda ()(print (current-process-id)))) - - ;; release lock here - - (mutex-unlock! *db-multi-sync-mutex*))) - (if (and debug-mode - (> (- start-time last-time) 60)) - (begin - (set! last-time start-time) - (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) - - ;; keep going unless time to exit - ;; - (if (not *time-to-exit*) - (let delay-loop ((count 0)) - ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) - - (if (and (not *time-to-exit*) - (< count 6)) ;; was 11, changing to 4. - (begin - (thread-sleep! 1) - (delay-loop (+ count 1)))) - (if (not *time-to-exit*) (loop)))) - ;; time to exit, close the no-sync db here - (db:no-sync-close-db no-sync-db) - (if (common:low-noise-print 30) - (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id) ))))))) ;;" this-wd-num="this-wd-num))))))) + (thread-sleep! 10) ;; delay for startup + (let* ((legacy-sync (common:run-sync?)) + (sqlite-exe (or (get-environment-variable "MT_SQLITE3_EXE"))) ;; defined in cfg.sh + (sync-log (or (args:get-arg "-sync-log") (conc *toppath* "/logs/sync-" (current-process-id) "-" (get-host-name) ".log"))) + (tmp-area (common:get-db-tmp-area)) + (tmp-db (conc tmp-area "/megatest.db")) + (staging-file (conc *toppath* "/.megatest.db")) + (mtdbfile (conc *toppath* "/megatest.db")) + (lockfile (conc tmp-db ".lock")) + (sync-cmd (conc sqlite-exe" " tmp-db " .dump | "sqlite-exe" " staging-file "&>"sync-log)) + (min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 30))) + (if (and (not (args:get-arg "-sync-to-megatest.db")) ;; conditions under which we do not run the sync + (args:get-arg "-server")) + (let loop () + (debug:print 0 *default-log-port* "INFO: syncer thread sleeping for server.minimum-intersync-delay seconds ["min-intersync-delay"]") + (thread-sleep! min-intersync-delay) + (if (common:simple-file-lock lockfile) + (begin + + (if (not (configf:lookup *configdat* "server" "disable-db-snapshot")) + (common:snapshot-file mtdbfile subdir: ".db-snapshot")) + (delete-file* staging-file) + (let* ((start-time (current-milliseconds)) + (res (system sync-cmd))) + (cond + ((eq? 0 res) + (delete-file* (conc mtdbfile ".backup")) + (if (eq? 0 (file-size sync-log)) + (delete-file sync-log)) + (system (conc "/bin/mv " staging-file " " mtdbfile)) + (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" SYNC took "(/ (- (current-milliseconds) start-time) 1000)" sec") + #t) + (else + (system (conc "/bin/cp "sync-log" "sync-log".fail")) + (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))))) + (common:simple-file-release-lock lockfile))) + ;; else + (debug:print 1 *default-log-port* "INFO: ["(common:human-time)"] pid="(current-process-id)" other SYNC in progress; not syncing.") + ) ;; end if got lockfile + + ;; keep going unless time to exit + ;; + (if (not *time-to-exit*) + (let delay-loop ((count 0)) + ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) + + (if (and (not *time-to-exit*) + (< count 6)) ;; was 11, changing to 4. + (begin + (thread-sleep! 1) + (delay-loop (+ count 1)))) + (if (not *time-to-exit*) (loop)))) + ;; time to exit, close the no-sync db here + ;; (db:no-sync-close-db no-sync-db) + (if (common:low-noise-print 30) + (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id) + )))))) + +;; (let ((legacy-sync (common:run-sync?))) +;; (sync-stale-seconds (configf:lookup-number *configdat* "server" "sync-stale-seconds" default: 300)) +;; (debug-mode (debug:debug-mode 1)) +;; (last-time (current-seconds)) +;; (no-sync-db (db:open-no-sync-db)) +;; (sync-duration 0) ;; run time of the sync in milliseconds +;; ;;(this-wd-num (begin (mutex-lock! *wdnum*mutex) (let ((x *wdnum*)) (set! *wdnum* (add1 *wdnum*)) (mutex-unlock! *wdnum*mutex) x))) +;; ) +;; (set! *no-sync-db* no-sync-db) ;; make the no sync db available to api calls +;; (debug:print-info 2 *default-log-port* "Periodic sync thread started.") +;; (debug:print-info 3 *default-log-port* "watchdog starting. legacy-sync is " legacy-sync" pid="(current-process-id) );; " this-wd-num="this-wd-num) +;; (if (and legacy-sync (not *time-to-exit*)) +;; (let* (;;(dbstruct (db:setup)) +;; (mtdb (dbr:dbstruct-mtdb dbstruct)) +;; (mtpath (db:dbdat-get-path mtdb)) +;; (tmp-area (common:get-db-tmp-area)) +;; (lockfile (conc tmp-area "/megatest.db.lock")) +;; (start-file (conc tmp-area "/.start-sync")) +;; (end-file (conc tmp-area "/.end-sync"))) +;; (debug:print-info 0 *default-log-port* "Server running, periodic sync started.") +;; (let loop () +;; ;; sync for filesystem local db writes +;; ;; +;; +;; (mutex-lock! *db-multi-sync-mutex*) +;; (let* ((need-sync (>= *db-last-access* *db-last-sync*)) ;; no sync since last write +;; (sync-in-progress *db-sync-in-progress*) +;; +;; (min-intersync-delay (configf:lookup-number *configdat* "server" "minimum-intersync-delay" default: 5)) +;; (should-sync (and (not *time-to-exit*) +;; (> (- (current-seconds) *db-last-sync*) min-intersync-delay))) ;; sync every five seconds minimum, deprecated logic, can probably be removed +;; (start-time (current-seconds)) +;; (cpu-load-adj (alist-ref 'adj-proc-load (common:get-normalized-cpu-load #f))) +;; (mt-mod-time (file-modification-time mtpath)) +;; (last-sync-start (if (common:file-exists? start-file) +;; (file-modification-time start-file) +;; 0)) +;; (last-sync-end (if (common:file-exists? end-file) +;; (file-modification-time end-file) +;; 10)) +;; (sync-period (+ 3 (* cpu-load-adj 30))) ;; as adjusted load increases increase the sync period +;; (recently-synced (and (< (- start-time mt-mod-time) sync-period) ;; not useful if sync didn't modify megatest.db! +;; (< mt-mod-time last-sync-start))) +;; (sync-done (<= last-sync-start last-sync-end)) +;; (sync-stale (> start-time (+ last-sync-start sync-stale-seconds))) +;; (will-sync-pre (and (not *time-to-exit*) ;; do not start a sync if we are in the process of exiting +;; have-lock? +;; (or need-sync should-sync) +;; (or sync-done sync-stale) +;; (not sync-in-progress) +;; (not recently-synced))) +;; (will-sync (if will-sync-pre +;; ;; delay get lock until we decide to sync +;; #t ;; (server:have-sync-lock?) +;; #f))) +;; ;; if another server is syncing, postpone sync +;; (if (and will-sync-pre (not will-sync)) +;; (set! *db-last-sync* start-time)) +;; (debug:print-info 13 *default-log-port* "WD writable-watchdog top of loop. need-sync="need-sync" sync-in-progress=" sync-in-progress +;; " should-sync="should-sync" start-time="start-time" mt-mod-time="mt-mod-time" recently-synced="recently-synced" will-sync="will-sync +;; " sync-done=" sync-done " sync-period=" sync-period) +;; (if (and (> sync-period 5) +;; (common:low-noise-print 30 "sync-period")) +;; (debug:print-info 0 *default-log-port* "Increased sync period due to long sync times, sync took: " sync-period " seconds.")) +;; ;; (if recently-synced (debug:print-info 0 *default-log-port* "Skipping sync due to recently-synced flag=" recently-synced)) +;; ;; (debug:print-info 0 *default-log-port* "need-sync: " need-sync " sync-in-progress: " sync-in-progress " should-sync: " should-sync " will-sync: " will-sync) +;; (if will-sync (set! *db-sync-in-progress* #t)) +;; (mutex-unlock! *db-multi-sync-mutex*) +;; (if will-sync +;; (let (;; (max-sync-duration (configf:lookup-number *configdat* "server" "max-sync-duration")) ;; KEEPING THIS AVAILABLE BUT SHOULD NOT USE, I'M PRETTY SURE IT DOES NOT WORK! +;; (sync-start (current-milliseconds))) +;; (with-output-to-file start-file (lambda ()(print (current-process-id)))) +;; +;; ;; put lock here +;; +;; ;; (if (or (not max-sync-duration) +;; ;; (< sync-duration max-sync-duration)) ;; NOTE: db:sync-to-megatest.db keeps track of time of last sync and syncs incrementally +;; (let ((res (db:sync-to-megatest.db dbstruct no-sync-db: no-sync-db))) ;; did we sync any data? If so need to set the db touched flag to keep the server alive +;; (set! sync-duration (- (current-milliseconds) sync-start)) +;; (if (> res 0) ;; some records were transferred, keep the db alive +;; (begin +;; (mutex-lock! *heartbeat-mutex*) +;; (set! *db-last-access* (current-seconds)) +;; (mutex-unlock! *heartbeat-mutex*) +;; (debug:print-info 0 *default-log-port* "sync called, " res " records transferred.")) +;; (debug:print-info 2 *default-log-port* "sync called but zero records transferred"))))) +;; ;; ;; TODO: factor this next routine out into a function +;; ;; (with-input-from-pipe ;; this should not block other threads but need to verify this +;; ;; (conc "megatest -sync-to-megatest.db -m testsuite:" (common:get-area-name) ":" *toppath*) +;; ;; (lambda () +;; ;; (let loop ((inl (read-line)) +;; ;; (res #f)) +;; ;; (if (eof-object? inl) +;; ;; (begin +;; ;; (set! sync-duration (- (current-milliseconds) sync-start)) +;; ;; (cond +;; ;; ((not res) +;; ;; (debug:print 0 *default-log-port* "ERROR: sync from /tmp db to megatest.db appears to have failed. Recommended that you stop your runs and run \"megatest -cleanup-db\"")) +;; ;; ((> res 0) +;; ;; (mutex-lock! *heartbeat-mutex*) +;; ;; (set! *db-last-access* (current-seconds)) +;; ;; (mutex-unlock! *heartbeat-mutex*)))) +;; ;; (let ((num-synced (let ((matches (string-match "^Synced (\\d+).*$" inl))) +;; ;; (if matches +;; ;; (string->number (cadr matches)) +;; ;; #f)))) +;; ;; (loop (read-line) +;; ;; (or num-synced res)))))))))) +;; (if will-sync +;; (begin +;; (mutex-lock! *db-multi-sync-mutex*) +;; (set! *db-sync-in-progress* #f) +;; (set! *db-last-sync* start-time) +;; (with-output-to-file end-file (lambda ()(print (current-process-id)))) +;; +;; ;; release lock here +;; ;; (server:release-sync-lock) +;; (mutex-unlock! *db-multi-sync-mutex*))) +;; (if (and debug-mode +;; (> (- start-time last-time) 60)) +;; (begin +;; (set! last-time start-time) +;; (debug:print-info 4 *default-log-port* "timestamp -> " (seconds->time-string (current-seconds)) ", time since start -> " (seconds->hr-min-sec (- (current-seconds) *time-zero*)))))) +;; +;; ;; keep going unless time to exit +;; ;; +;; (if (not *time-to-exit*) +;; (let delay-loop ((count 0)) +;; ;;(debug:print-info 13 *default-log-port* "delay-loop top; count="count" pid="(current-process-id)" this-wd-num="this-wd-num" *time-to-exit*="*time-to-exit*) +;; +;; (if (and (not *time-to-exit*) +;; (< count 6)) ;; was 11, changing to 4. +;; (begin +;; (thread-sleep! 1) +;; (delay-loop (+ count 1)))) +;; (if (not *time-to-exit*) (loop)))) +;; ;; time to exit, close the no-sync db here +;; (db:no-sync-close-db no-sync-db) +;; (if (common:low-noise-print 30) +;; (debug:print-info 0 *default-log-port* "Exiting watchdog timer, *time-to-exit* = " *time-to-exit*" pid="(current-process-id) ))))))) ;;" this-wd-num="this-wd-num))))))) Index: spublish.scm ================================================================== --- spublish.scm +++ spublish.scm @@ -22,11 +22,11 @@ (use srfi-18) (use srfi-19) (use format) (use sql-de-lite srfi-1 posix regex regex-case srfi-69) -(declare (uses configf)) +;(declare (uses configf)) ;; (declare (uses tree)) (declare (uses margs)) (declare (uses megatest-version)) ;; (declare (uses tbd)) Index: sretrieve.scm ================================================================== --- sretrieve.scm +++ sretrieve.scm @@ -362,11 +362,11 @@ (let* ((projects `())) (if (sretrieve:has-permission area) (set! projects (cons area projects)) (begin - (print "User cannot access area " area "!!") + (sauth:print-error (conc "User cannot access area " area "!!")) (exit 1))) ; (print projects) projects)) (define (sauth-common:shell-ls-cmd base-path-list ext-path top-areas base-path tail-cmd-list) Index: subrun.scm ================================================================== --- subrun.scm +++ subrun.scm @@ -118,10 +118,19 @@ (begin (subrun:set-subrun-removed test-run-dir) #t) #f)) #t)) + +(define (subrun:kill-subrun test-run-dir ) + (if (and (not (subrun:subrun-removed? test-run-dir)) (subrun:subrun-test-initialized? test-run-dir)) + (let* ((action-switches-str + (conc "-kill-runs" )) + (kill-result + (subrun:exec-sub-megatest test-run-dir action-switches-str "kill"))) + kill-result) + #t)) (define (subrun:launch-cmd test-run-dir) (if (subrun:subrun-removed? test-run-dir) (subrun:unset-subrun-removed test-run-dir)) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -738,11 +738,11 @@ ;; gets mtpg-run-id and syncs the record if different ;; -(define (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info) +(define (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time) (let* ((runs-ht (hash-table-ref cached-info 'runs)) (runinf (hash-table-ref/default runs-ht run-id #f)) (area-id (vector-ref area-info 0))) (if runinf runinf ;; already cached @@ -762,46 +762,53 @@ (if (and db-contour (not (equal? db-contour "")) (string? db-contour )) (begin (debug:print-info 1 *default-log-port* "db-contour") db-contour) (args:get-arg "-contour")))) + (last-update (db:get-value-by-header row header "last_update")) (keytarg (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target")) (conc "MT_CONTOUR/MT_AREA/" (string-intersperse (rmt:get-keys) "/")) (string-intersperse (rmt:get-keys) "/"))) ;; e.g. version/iteration/platform (target (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target")) (conc (or (args:get-arg "-prefix-target") (conc contour "/" (common:get-area-name) "/")) (rmt:get-target run-id)) (rmt:get-target run-id))) ;; e.g. v1.63/a3e1/ubuntu (spec-id (pgdb:get-ttype dbh keytarg)) - (new-run-id (pgdb:get-run-id dbh spec-id target run-name area-id)) - ;; (area-id (db:get-value-by-header row header "area_id)")) - ) - (if new-run-id - (begin ;; let ((run-record (pgdb:get-run-info dbh new-run-id)) - (hash-table-set! runs-ht run-id new-run-id) + (new-run-id (pgdb:get-run-id dbh spec-id target run-name area-id))) + (if new-run-id + (begin ;; let ((run-record (pgdb:get-run-info dbh new-run-id)) + (hash-table-set! runs-ht run-id new-run-id) ;; ensure key fields are up to date + ;; if last_update == pgdb_last_update do not update smallest-last-update-time + (let* ((pgdb-last-update (pgdb:get-run-last-update dbh new-run-id)) + (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f))) + (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time))) + (hash-table-set! smallest-last-update-time "smallest-time" last-update))) (pgdb:refresh-run-info dbh new-run-id - state status owner event-time comment fail-count pass-count area-id) - (debug:print-info 1 *default-log-port* "Working on run-id " run-id " pgdb-id" new-run-id ) - new-run-id) + state status owner event-time comment fail-count pass-count area-id last-update) + (debug:print-info 1 *default-log-port* "Working on run-id " run-id " pgdb-id " new-run-id ) + new-run-id) (if (equal? state "deleted") - (begin - (debug:print-info 1 *default-log-port* "Warning: Run with id " run-id " was created after previous sync and deleted before the sync") #f) - (if (handle-exceptions - exn - (begin (print-call-chain) - (print ((condition-property-accessor 'exn 'message) exn)) - #f) - - (pgdb:insert-run + (begin + (debug:print-info 1 *default-log-port* "Warning: Run with id " run-id " was created after previous sync and deleted before the sync") #f) + (if (handle-exceptions + exn + (begin (print-call-chain) + (print ((condition-property-accessor 'exn 'message) exn)) + #f) + ;(print "inserting") + (pgdb:insert-run dbh - spec-id target run-name state status owner event-time comment fail-count pass-count area-id)) - (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info) + spec-id target run-name state status owner event-time comment fail-count pass-count area-id last-update)) + (let* ((smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f))) + (if (or (not smallest-time) (< last-update smallest-time)) + (hash-table-set! smallest-last-update-time "smallest-time" last-update)) + (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time)) #f))))))) -(define (tasks:sync-test-steps dbh cached-info test-step-ids) +(define (tasks:sync-test-steps dbh cached-info test-step-ids smallest-last-update-time) ; (print "Sync Steps " test-step-ids ) (let ((test-ht (hash-table-ref cached-info 'tests)) (step-ht (hash-table-ref cached-info 'steps))) (for-each (lambda (test-step-id) @@ -812,32 +819,39 @@ (state (tdb:step-get-state test-step-info)) (status (tdb:step-get-status test-step-info)) (event_time (tdb:step-get-event_time test-step-info)) (comment (tdb:step-get-comment test-step-info)) (logfile (tdb:step-get-logfile test-step-info)) + (last-update (tdb:step-get-last_update test-step-info)) (pgdb-test-id (hash-table-ref/default test-ht test-id #f)) - (pgdb-step-id (if pgdb-test-id - (pgdb:get-test-step-id dbh pgdb-test-id stepname state) - #f))) + (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f)) + (pgdb-step-id (if pgdb-test-id + (pgdb:get-test-step-id dbh pgdb-test-id stepname state) + #f))) (if step-id (begin (if pgdb-test-id (begin (if pgdb-step-id (begin (debug:print-info 1 *default-log-port* "Updating existing test-step with test-id: " test-id " and step-id " step-id " pgdb test id: " pgdb-test-id " pgdb step id " pgdb-step-id ) - (pgdb:update-test-step dbh pgdb-step-id pgdb-test-id stepname state status event_time comment logfile)) + (let* ((pgdb-last-update (pgdb:get-test-step-last-update dbh pgdb-step-id))) + (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time))) + (hash-table-set! smallest-last-update-time "smallest-time" last-update))) + (pgdb:update-test-step dbh pgdb-step-id pgdb-test-id stepname state status event_time comment logfile last-update)) (begin (debug:print-info 1 *default-log-port* "Inserting test-step with test-id: " test-id " and step-id " step-id " pgdb test id: " pgdb-test-id) - (pgdb:insert-test-step dbh pgdb-test-id stepname state status event_time comment logfile ) + (if (or (not smallest-time) (< last-update smallest-time)) + (hash-table-set! smallest-last-update-time "smallest-time" last-update)) + (pgdb:insert-test-step dbh pgdb-test-id stepname state status event_time comment logfile last-update ) (set! pgdb-step-id (pgdb:get-test-step-id dbh pgdb-test-id stepname state)))) (hash-table-set! step-ht step-id pgdb-step-id )) (debug:print-info 1 *default-log-port* "Error: Test not cashed"))) (debug:print-info 1 *default-log-port* "Error: Could not get test step info for step id " test-step-id )))) ;; this is a wierd senario need to debug test-step-ids))) -(define (tasks:sync-test-gen-data dbh cached-info test-data-ids) +(define (tasks:sync-test-gen-data dbh cached-info test-data-ids smallest-last-update-time) (let ((test-ht (hash-table-ref cached-info 'tests)) (data-ht (hash-table-ref cached-info 'data))) (for-each (lambda (test-data-id) (let* ((test-data-info (rmt:get-data-info-by-id test-data-id)) @@ -849,11 +863,14 @@ (expected (db:test-data-get-expected test-data-info)) (tol (db:test-data-get-tol test-data-info)) (units (db:test-data-get-units test-data-info)) (comment (db:test-data-get-comment test-data-info)) (status (db:test-data-get-status test-data-info)) - (type (db:test-data-get-type test-data-info)) + (type (db:test-data-get-type test-data-info)) + (last-update (db:test-data-get-last_update test-data-info)) + (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f)) + (pgdb-test-id (hash-table-ref/default test-ht test-id #f)) (pgdb-data-id (if pgdb-test-id (pgdb:get-test-data-id dbh pgdb-test-id category variable) #f))) (if data-id @@ -861,39 +878,44 @@ (if pgdb-test-id (begin (if pgdb-data-id (begin (debug:print-info 1 *default-log-port* "Updating existing test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id " pgdb data id " pgdb-data-id) - (pgdb:update-test-data dbh pgdb-data-id pgdb-test-id category variable value expected tol units comment status type)) + (let* ((pgdb-last-update (pgdb:get-test-data-last-update dbh pgdb-data-id))) + (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time))) + (hash-table-set! smallest-last-update-time "smallest-time" last-update))) + (pgdb:update-test-data dbh pgdb-data-id pgdb-test-id category variable value expected tol units comment status type last-update)) (begin (debug:print-info 1 *default-log-port* "Inserting test-data with test-id: " test-id " and data-id " data-id " pgdb test id: " pgdb-test-id) (if (handle-exceptions exn (begin (print-call-chain) (print ((condition-property-accessor 'exn 'message) exn)) #f) - (pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type )) + (pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type last-update)) ;(tasks:run-id->mtpg-run-id dbh cached-info run-id area-info) (begin ;(pgdb:insert-test-data dbh pgdb-test-id category variable value expected tol units comment status type ) + (if (or (not smallest-time) (< last-update smallest-time)) + (hash-table-set! smallest-last-update-time "smallest-time" last-update)) (set! pgdb-data-id (pgdb:get-test-data-id dbh pgdb-test-id category variable))) - (exit)))) + #f))) (hash-table-set! data-ht data-id pgdb-data-id )) (begin (debug:print-info 1 *default-log-port* "Error: Test not in pgdb")))) (debug:print-info 1 *default-log-port* "Error: Could not get test data info for data id " test-data-id )))) ;; this is a wierd senario need to debug test-data-ids))) -(define (tasks:sync-tests-data dbh cached-info test-ids area-info) +(define (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time) (let ((test-ht (hash-table-ref cached-info 'tests))) (for-each (lambda (test-id) - ;(print test-id) + ; (print test-id) (let* ((test-info (rmt:get-test-info-by-id #f test-id)) (run-id (db:test-get-run_id test-info)) ;; look these up in db_records.scm (test-id (db:test-get-id test-info)) (test-name (db:test-get-testname test-info)) (item-path (db:test-get-item-path test-info)) @@ -907,12 +929,13 @@ (log-file (db:test-get-final_logf test-info)) (run-duration (db:test-get-run_duration test-info)) (comment (db:test-get-comment test-info)) (event-time (db:test-get-event_time test-info)) (archived (db:test-get-archived test-info)) - (pgdb-run-id (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info)) - + (last-update (db:test-get-last_update test-info)) + (pgdb-run-id (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time)) + (smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f)) (pgdb-test-id (if pgdb-run-id (begin ;(print pgdb-run-id) (pgdb:get-test-id dbh pgdb-run-id test-name item-path)) #f))) @@ -921,18 +944,23 @@ ;; "run_duration" "final_logf" "comment" "shortdir" "attemptnum" "archived" (if pgdb-run-id (begin (if pgdb-test-id ;; have a record (begin ;; let ((key-name (conc run-id "/" test-name "/" item-path))) - (debug:print-info 1 *default-log-port* "Updating existing test with run-id: " run-id " and test-id: " test-id " pgdb run id: " pgdb-run-id " pgdb-test-id " pgdb-test-id) - (pgdb:update-test dbh pgdb-test-id pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived)) + (debug:print-info 0 *default-log-port* "Updating existing test with run-id: " run-id " and test-id: " test-id " pgdb run id: " pgdb-run-id " pgdb-test-id " pgdb-test-id) + (let* ((pgdb-last-update (pgdb:get-test-last-update dbh pgdb-test-id))) + (if (and (> last-update pgdb-last-update) (or (not smallest-time) (< last-update smallest-time))) ;;if last-update is same as pgdb-last-update then it is safe to assume the records are identical and we can use a larger last update time. + (hash-table-set! smallest-last-update-time "smallest-time" last-update))) + (pgdb:update-test dbh pgdb-test-id pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived last-update)) (begin - (debug:print-info 1 *default-log-port* "Inserting test with run-id: " run-id " and test-id: " test-id " pgdb run id: " pgdb-run-id) - (pgdb:insert-test dbh pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived) - (set! pgdb-test-id (pgdb:get-test-id dbh pgdb-run-id test-name item-path)))) - (hash-table-set! test-ht test-id pgdb-test-id)) - (debug:print-info 1 *default-log-port* "WARNING: Skipping run with run-id:" run-id ". This run was created after privious sync and removed before this sync.")))) + (debug:print-info 0 *default-log-port* "Inserting test with run-id: " run-id " and test-id: " test-id " pgdb run id: " pgdb-run-id) + (pgdb:insert-test dbh pgdb-run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived last-update) + (if (or (not smallest-time) (< last-update smallest-time)) + (hash-table-set! smallest-last-update-time "smallest-time" last-update)) + (set! pgdb-test-id (pgdb:get-test-id dbh pgdb-run-id test-name item-path)))) + (hash-table-set! test-ht test-id pgdb-test-id)) + (debug:print-info 1 *default-log-port* "WARNING: Skipping run with run-id:" run-id ". This run was created after privious sync and removed before this sync.")))) test-ids))) (define (task:add-area-tag dbh area-info tag) (let* ((tag-info (pgdb:get-tag-info-by-name dbh tag))) (if (not tag-info) @@ -952,15 +980,15 @@ (debug:print-info 1 *default-log-port* ((condition-property-accessor 'exn 'message) exn)) #f) (if (not (pgdb:is-area-taged-with-a-tag dbh (vector-ref tag-info 0) (vector-ref area-info 0))) (pgdb:insert-area-tag dbh (vector-ref tag-info 0) (vector-ref area-info 0)))))) -(define (tasks:sync-run-data dbh cached-info run-ids area-info) +(define (tasks:sync-run-data dbh cached-info run-ids area-info smallest-last-update-time) (for-each (lambda (run-id) (debug:print-info 1 *default-log-port* "Check if run with " run-id " needs to be synced" ) - (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info)) + (tasks:run-id->mtpg-run-id dbh cached-info run-id area-info smallest-last-update-time)) run-ids)) ;; get runs changed since last sync ;; (define (tasks:sync-test-data dbh cached-info area-info) @@ -968,42 +996,70 @@ (define (tasks:sync-to-postgres configdat dest) (let* ((dbh (pgdb:open configdat dbname: dest)) (area-info (pgdb:get-area-by-path dbh *toppath*)) (cached-info (make-hash-table)) - (start (current-seconds))) + (start (current-seconds)) + (test-patt (if (args:get-arg "-testpatt") + (args:get-arg "-testpatt") + "%")) + (target (if (args:get-arg "-target") + (args:get-arg "-target") + #f)) + (run-name (if (args:get-arg "-runname") + (args:get-arg "-runname") + #f))) + (if (and target (not run-name)) + (begin + (print "Error: Provide runname") + (exit 1))) + (if (and (not target) run-name) + (begin + (print "Error: Provide target") + (exit 1))) + (for-each (lambda (dtype) (hash-table-set! cached-info dtype (make-hash-table))) '(runs targets tests steps data)) (hash-table-set! cached-info 'start start) ;; when done we'll set sync times to this (if area-info (let* ((last-sync-time (vector-ref area-info 3)) - (changed (rmt:get-changed-record-ids last-sync-time)) + (smallest-last-update-time (make-hash-table)) + (changed (if (and target run-name) + (rmt:get-run-record-ids target run-name (rmt:get-keys) test-patt) + (rmt:get-changed-record-ids last-sync-time))) (run-ids (alist-ref 'runs changed)) (test-ids (alist-ref 'tests changed)) (test-step-ids (alist-ref 'test_steps changed)) (test-data-ids (alist-ref 'test_data changed)) (run-stat-ids (alist-ref 'run_stats changed)) (area-tag (if (args:get-arg "-area-tag") (args:get-arg "-area-tag") - ""))) + (if (args:get-arg "-area") + (args:get-arg "-area") + "")))) (if (and (equal? area-tag "") (not (pgdb:is-area-taged dbh (vector-ref area-info 0)))) (set! area-tag *default-area-tag*)) (if (not (equal? area-tag "")) (task:add-area-tag dbh area-info area-tag)) (if (or (not (null? test-ids)) (not (null? run-ids))) (begin - (debug:print-info 1 *default-log-port* "Syncing " (length test-step-ids) " changed tests") - ;;Assumption here is that if test-step or test data is changed then the test last update time is changed - ;; not syncing run stats at this time as they can be derived from tests table. - (tasks:sync-tests-data dbh cached-info test-ids area-info) - ;(exit) - (tasks:sync-run-data dbh cached-info run-ids area-info) - (tasks:sync-test-steps dbh cached-info test-step-ids) - (tasks:sync-test-gen-data dbh cached-info test-data-ids))) - (pgdb:write-sync-time dbh area-info (- start 1))) + (debug:print-info 0 *default-log-port* "syncing runs") + (tasks:sync-run-data dbh cached-info run-ids area-info smallest-last-update-time) + (debug:print-info 0 *default-log-port* "syncing tests") + (tasks:sync-tests-data dbh cached-info test-ids area-info smallest-last-update-time) + (debug:print-info 0 *default-log-port* "syncing test steps") + (tasks:sync-test-steps dbh cached-info test-step-ids smallest-last-update-time) + (debug:print-info 0 *default-log-port* "syncing test data") + (tasks:sync-test-gen-data dbh cached-info test-data-ids smallest-last-update-time) + (print "----------done---------------"))) + (let* ((smallest-time (hash-table-ref/default smallest-last-update-time "smallest-time" #f))) + (print "smallest-time :" smallest-time " last-sync-time " last-sync-time) + (if (not (and target run-name)) + (if (or (and smallest-time (> smallest-time last-sync-time)) (and smallest-time (eq? last-sync-time 0))) + (pgdb:write-sync-time dbh area-info smallest-time))))) ;;this needs to be changed (if (tasks:set-area dbh configdat) (tasks:sync-to-postgres configdat dest) (begin (debug:print 0 *default-log-port* "ERROR: unable to create an area record") #f))))) ADDED telemetry-daemon Index: telemetry-daemon ================================================================== --- /dev/null +++ telemetry-daemon @@ -0,0 +1,265 @@ +#!/usr/bin/env python +# -*- Mode: Python; -*- +## Tiny Syslog Server in Python. +## +## This is a tiny syslog server that is able to receive UDP based syslog +## entries on a specified port and save them to a file. +## That's it... it does nothing else... + + +import os +import sys, os, time, atexit +from signal import SIGTERM +import logging +import logging.handlers +import SocketServer +import datetime +from subprocess import call +import argparse +import os +import socket + +## code to determine this host's IP on non-loopback interface +if os.name != "nt": + import fcntl + import struct + + def get_interface_ip(ifname): + s = socket.socket(socket.AF_INET, socket.SOCK_DGRAM) + return socket.inet_ntoa(fcntl.ioctl(s.fileno(), 0x8915, struct.pack('256s', + ifname[:15]))[20:24]) + +def get_lan_ip(): + ip = socket.gethostbyname(socket.gethostname()) + if ip.startswith("127.") and os.name != "nt": + interfaces = [ + "eth0", + "eth1", + "eth2", + "wlan0", + "wlan1", + "wifi0", + "ath0", + "ath1", + "ppp0", + ] + for ifname in interfaces: + try: + ip = get_interface_ip(ifname) + break + except IOError: + pass + return ip + +class Daemon(object): + """ + A generic daemon class. + + Usage: subclass the Daemon class and override the run() method + """ + def __init__(self, pidfile, stdin='/dev/null', stdout='/dev/null', stderr='/dev/null'): + self.stdin = stdin + self.stdout = stdout + self.stderr = stderr + self.pidfile = pidfile + + def daemonize(self): + """ + do the UNIX double-fork magic, see Stevens' "Advanced + Programming in the UNIX Environment" for details (ISBN 0201563177) + http://www.erlenstar.demon.co.uk/unix/faq_2.html#SEC16 + """ + try: + pid = os.fork() + if pid > 0: + # exit first parent + sys.exit(0) + except OSError, e: + sys.stderr.write("fork #1 failed: %d (%s)\n" % (e.errno, e.strerror)) + sys.exit(1) + + # decouple from parent environment + os.chdir("/") + os.setsid() + os.umask(0) + + # do second fork + try: + pid = os.fork() + if pid > 0: + # exit from second parent + sys.exit(0) + except OSError, e: + sys.stderr.write("fork #2 failed: %d (%s)\n" % (e.errno, e.strerror)) + sys.exit(1) + + # redirect standard file descriptors + sys.stdout.flush() + sys.stderr.flush() + si = file(self.stdin, 'r') + so = file(self.stdout, 'a+') + se = file(self.stderr, 'a+', 0) + os.dup2(si.fileno(), sys.stdin.fileno()) + os.dup2(so.fileno(), sys.stdout.fileno()) + os.dup2(se.fileno(), sys.stderr.fileno()) + + # write pidfile + atexit.register(self.delpid) + pid = str(os.getpid()) + file(self.pidfile,'w+').write("%s\n" % pid) + + def delpid(self): + os.remove(self.pidfile) + + def start(self): + """ + Start the daemon + """ + # Check for a pidfile to see if the daemon already runs + try: + pf = file(self.pidfile,'r') + pid = int(pf.read().strip()) + pf.close() + except IOError: + pid = None + + if pid: + message = "pidfile %s already exist. Daemon already running?\n" + sys.stderr.write(message % self.pidfile) + sys.exit(1) + + # Start the daemon + self.daemonize() + self.run() + + def stop(self): + """ + Stop the daemon + """ + # Get the pid from the pidfile + try: + pf = file(self.pidfile,'r') + pid = int(pf.read().strip()) + pf.close() + except IOError: + pid = None + + if not pid: + message = "pidfile %s does not exist. Daemon not running?\n" + sys.stderr.write(message % self.pidfile) + return # not an error in a restart + + # Try killing the daemon process + try: + while 1: + os.kill(pid, SIGTERM) + time.sleep(0.1) + except OSError, err: + err = str(err) + if err.find("No such process") > 0: + if os.path.exists(self.pidfile): + os.remove(self.pidfile) + else: + print str(err) + sys.exit(1) + + def restart(self): + """ + Restart the daemon + """ + self.stop() + self.start() + + def run(self): + """ + You should override this method when you subclass Daemon. It will be called after the process has been + daemonized by start() or restart(). + """ + +# setup logging module so that the log can be moved aside and will reopen for append +def log_setup(logfile): + log_handler = logging.handlers.WatchedFileHandler(logfile) + formatter = logging.Formatter( + '%(message)s','') + log_handler.setFormatter(formatter) + logger = logging.getLogger() + logger.addHandler(log_handler) + logger.setLevel(logging.INFO) + + +class SyslogUDPHandler(SocketServer.BaseRequestHandler): + def handle(self): + data = bytes.decode(self.request[0].strip()) + socket = self.request[1] + print( "%s : " % self.client_address[0], str(data)) + timestamp = datetime.datetime.now().isoformat() + logline = timestamp + ":"+self.client_address[0] + ":" + str(data) + logging.info(str(logline)) + + + +class TelemetryLogDaemon(Daemon): + def __init__(self, pidfile, logfile, server_ip, server_port): + self.logfile = logfile + self.server_ip = server_ip + self.server_port = server_port + super(TelemetryLogDaemon, self).__init__(pidfile) + + def run(self): + log_setup(self.logfile) + server = SocketServer.UDPServer((self.server_ip,int(self.server_port)), SyslogUDPHandler) + server.serve_forever(poll_interval=0.5) + + +def main(): + default_log_file = os.environ['PWD'] + "/telemetry.log" + + parser = argparse.ArgumentParser(description = 'telemetry-daemon') + actions="start,restart,stop,nodaemon".split(",") + + parser.add_argument("-a", "--action", required=True, choices=actions, help="manage daemon: start stop or restart") + parser.add_argument("-p", "--server-port", default="5929", help="specify alternate udp port number, default is 5929") + parser.add_argument("-i", "--server-ip", default=get_lan_ip(), help="specify IP if heuristics to get local host lan ip fails") + parser.add_argument("-l", "--log-file", default=default_log_file, help="specify log file to write") + parser.add_argument("-z", "--pid-file", default=default_log_file + ".pidfile", help="specify pidfile") + opts = parser.parse_args() + + tld = TelemetryLogDaemon(opts.pid_file, opts.log_file, opts.server_ip, opts.server_port) + + if opts.action == "start": + print "Info: Starting server" + print """Example addition to megatest.config to enable telemetry: + +[telemetry] +host %s +port %s +want-events ALL + + """ % (opts.server_ip, opts.server_port) + tld.start() + + elif opts.action == "stop": + tld.stop() + elif opts.action == "restart": + + print "Info: Restarting server" + print """Example addition to megatest.config to enable telemetry: + +[telemetry] +host %s +port %s +want-events ALL + + """ % (opts.server_ip, opts.server_port) + tld.restart() + elif opts.action == "nodaemon": + log_setup(opts.log_file) + server = SocketServer.UDPServer((opts.server_ip,int(opts.server_port)), SyslogUDPHandler) + server.serve_forever(poll_interval=0.5) + +if __name__ == '__main__': + main() + + + + Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -1517,11 +1517,11 @@ ;; if .testconfig exists in test directory read and return it ;; else if have cached copy in *testconfigs* return it IFF there is a section "have fulldata" ;; else read the testconfig file ;; if have path to test directory save the config as .testconfig and return it ;; -(define (tests:get-testconfig test-name item-path test-registry system-allowed #!key (force-create #f)(allow-write-cache #t)) +(define (tests:get-testconfig test-name item-path test-registry system-allowed #!key (force-create #f)(allow-write-cache #t)(wait-a-minute #f)) (let* ((use-cache (common:use-cache?)) (cache-path (tests:get-test-path-from-environment)) (cache-file (and cache-path (conc cache-path "/.testconfig"))) (cache-exists (and cache-file (not force-create) ;; if force-create then pretend there is no cache to read @@ -1545,13 +1545,37 @@ dat ;; no cached data available (let* ((treg (or test-registry (tests:get-all))) (test-path (or (hash-table-ref/default treg test-name #f) + (let* ((local-tcdir (conc (getenv "MT_LINKTREE") "/" + (getenv "MT_TARGET") "/" + (getenv "MT_RUNNAME") "/" + test-name "/" item-path)) + (local-tcfg (conc local-tcdir "/testconfig"))) + (if (common:file-exists? local-tcfg) + local-tcdir + #f)) (conc *toppath* "/tests/" test-name))) (test-configf (conc test-path "/testconfig")) - (testexists (and (common:file-exists? test-configf)(file-read-access? test-configf))) + (testexists (let loopa ((tries-left 30)) + (cond + ( + (and (common:file-exists? test-configf)(file-read-access? test-configf)) + #t) + ( + (common:file-exists? test-configf) + (debug:print 0 *default-log-port* "WARNING: Cannot read testconfig file: "test-configf) + #f) + ( + (and wait-a-minute (> tries-left 0)) + (thread-sleep! 10) + (debug:print 0 *default-log-port* "WARNING: testconfig file does not exist: "test-configf" will retry in 10 seconds. Tries left: "tries-left) ;; BB: this fires + (loopa (sub1 tries-left))) + (else + (debug:print 0 *default-log-port* "WARNING: testconfig file does not exist: "test-configf) ;; BB: this fires + #f)))) (tcfg (if testexists (read-config test-configf #f system-allowed environ-patt: (if system-allowed "pre-launch-env-vars" #f)) @@ -1562,11 +1586,11 @@ cache-file (file-write-access? cache-path) allow-write-cache) (let ((tpath (conc cache-path "/.testconfig"))) (debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath) - (if (not (common:in-running-test?)) + (if (and tcfg (not (common:in-running-test?))) (configf:write-alist tcfg tpath)))) tcfg)))))) ;; sort tests by priority and waiton ;; Move test specific stuff to a test unit FIXME one of these days Index: utils/mk_wrapper ================================================================== --- utils/mk_wrapper +++ utils/mk_wrapper @@ -19,19 +19,33 @@ prefix=$1 cmd=$2 target=$3 cfgfile="$prefix/bin/.$(lsb_release -sr)/cfg.sh" + +# we wish to create a var in cfg.sh for finding sqlite3 executable +chicken_bin_dir=$(dirname $(which csi)) +if [[ -e $chicken_bin_dir/sqlite3 ]];then + sqlite3_exe=$chicken_bin_dir/sqlite3 +else + sqlite3_exe=$(which sqlite3) +fi if [ "$LD_LIBRARY_PATH" != "" ];then echo "INFO: Using LD_LIBRARY_PATH=$LD_LIBRARY_PATH" >&2 ( cat << __EOF +if [ -z \$MT_ORIG_ENV ]; then + export MT_ORIG_ENV=\$( $prefix/bin/serialize-env ) +fi + if [ "\$LD_LIBRARY_PATH" != "" ];then export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:\$LD_LIBRARY_PATH else export LD_LIBRARY_PATH=$LD_LIBRARY_PATH fi + +export MT_SQLITE3_EXE=$sqlite3_exe __EOF ) > $cfgfile echo else echo "INFO: LD_LIBRARY_PATH not set" >&2 Index: wrappers/cfg.sh ================================================================== --- wrappers/cfg.sh +++ wrappers/cfg.sh @@ -12,10 +12,14 @@ # 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 . + +if [ -z $MT_ORIG_ENV ]; then + export MT_ORIG_ENV=$( PREFIX/bin/serialize-env ) +fi if [ "$LD_LIBRARY_PATH" != "" ];then export LD_LIBRARY_PATH=PREFIX:PREFIX/lib:PREFIX/lib64:$LD_LIBRARY_PATH else export LD_LIBRARY_PATH=PREFIX:PREFIX/lib:PREFIX/lib64 Index: wrappers/megatest ================================================================== --- wrappers/megatest +++ wrappers/megatest @@ -15,10 +15,10 @@ # 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 . -if [[ $(ulimit -a | grep 'open files' | awk '{print $4}') -gt 10000 ]];then ulimit -n 10000;fi +if [[ $(ulimit -a | grep 'open files' | awk '{print $4}') -gt 20000 ]];then ulimit -n 20000;fi lsbr=$(lsb_release -sr) source PREFIX/ARCHSTR/cfg.sh exec PREFIX/mtest "$@"