Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -69,11 +69,11 @@ # ARCHSTR=$(shell bash -c "echo \$$MACHTYPE") PNGFILES = $(shell cd docs/manual;ls *png) #all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard -all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut +all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut tcmt mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) mofiles/ftail.o csc $(CSCOPTS) $(OFILES) $(MOFILES) megatest.o -o mtest showmtesthash: @@ -303,11 +303,11 @@ $(MTQA_FOSSIL) : fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL) clean : - rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o + rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil mtut tcmt ftail.import.scm readline-fix.scm serialize-env share dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o #====================================================================== # Make the records files #====================================================================== @@ -422,5 +422,8 @@ arora docs/manual/megatest_manual.html targets: @grep : Makefile | perl -ne '/^([A-Za-z0-9_-]+):/ && print "$$1\n"' + +unit : + cd tests;make unit Index: cgisetup/models/pgdb.scm ================================================================== --- cgisetup/models/pgdb.scm +++ cgisetup/models/pgdb.scm @@ -113,10 +113,14 @@ (define (pgdb:insert-tag dbh name ) (dbi:exec dbh "INSERT INTO tags (tag_name) VALUES (?)" name )) (define (pgdb:insert-area-tag dbh tag-id area-id ) (dbi:exec dbh "INSERT INTO area_tags (tag_id, area_id) VALUES (?,?)" tag-id area-id )) + +(define (pgdb:insert-run-tag dbh tag-id run-id ) + (dbi:exec dbh "INSERT INTO run_tags (tag_id, run_id) VALUES (?,?)" tag-id run-id )) + (define (pgdb:is-area-taged dbh area-id) (let ((area-tag-id (dbi:get-one dbh "SELECT id FROM area_tags WHERE area_id=?;" area-id))) (if area-tag-id #t @@ -125,10 +129,17 @@ (define (pgdb:is-area-taged-with-a-tag dbh tag-id area-id) (let ((area-tag-id (dbi:get-one dbh "SELECT id FROM area_tags WHERE area_id=? and tag_id=?;" area-id tag-id))) (if area-tag-id #t #f))) + +(define (pgdb:is-run-taged-with-a-tag dbh tag-id run-id) + (let ((run-tag-id (dbi:get-one dbh "SELECT id FROM run_tags WHERE run_id=? and tag_id=?;" run-id tag-id))) + (if run-tag-id + #t + #f))) + ;;====================================================================== ;; R U N S ;;====================================================================== @@ -155,26 +166,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 last_update) ;; area-id) +(define (pgdb:refresh-run-info dbh run-id state status owner event-time comment fail-count pass-count area-id last_update publish-time) ;; area-id) (dbi:exec dbh "UPDATE runs SET - state=?,status=?,owner=?,event_time=?,comment=?,fail_count=?,pass_count=?,last_update=? + state=?,status=?,owner=?,event_time=?,comment=?,fail_count=?,pass_count=?,last_update=?,publish_time=? WHERE id=? and area_id=?;" - state status owner event-time comment fail-count pass-count last_update run-id area-id )) + state status owner event-time comment fail-count pass-count last_update publish-time run-id area-id )) ;; given all needed info create run record ;; -(define (pgdb:insert-run dbh ttype-id target run-name state status owner event-time comment fail-count pass-count area-id last-update) +(define (pgdb:insert-run dbh ttype-id target run-name state status owner event-time comment fail-count pass-count area-id last-update publish-time) (dbi:exec dbh - "INSERT INTO runs (ttype_id,target,run_name,state,status,owner,event_time,comment,fail_count,pass_count,area_id,last_update) - VALUES (?,?,?,?,?,?,?,?,?,?,?,?);" - ttype-id target run-name state status owner event-time comment fail-count pass-count area-id last-update)) + "INSERT INTO runs (ttype_id,target,run_name,state,status,owner,event_time,comment,fail_count,pass_count,area_id,last_update,publish_time) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?, ?);" + ttype-id target run-name state status owner event-time comment fail-count pass-count area-id last-update publish-time)) ;;====================================================================== ;; T E S T - S T E P S ;;====================================================================== @@ -188,15 +199,15 @@ (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) +(define (pgdb:insert-test-step dbh test-id stepname state status event_time comment logfile last-update ) (dbi:exec dbh "INSERT INTO test_steps (test_id,stepname,state,status,event_time,logfile,comment,last_update) - VALUES (?,?,?,?,?,?,?, ? );" + VALUES (?,?,?,?,?,?,?,? );" test-id stepname state status event_time logfile comment last-update)) (define (pgdb:update-test-step dbh step-id test-id stepname state status event_time comment logfile last-update) (dbi:exec dbh @@ -271,30 +282,30 @@ id )) ;; create new test record ;; -(define (pgdb:insert-test dbh run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived last-update) +(define (pgdb:insert-test dbh run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived last-update pid) (dbi:exec dbh - "INSERT INTO tests (run_id,test_name,item_path,state,status,host,cpuload,diskfree,uname,rundir,final_logf,run_duration,comment,event_time,archived,last_update) - 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,attemptnum) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?);" run-id test-name item-path state status host cpuload diskfree uname - run-dir log-file run-duration comment event-time archived last-update)) + run-dir log-file run-duration comment event-time archived last-update pid)) ;; update existing test record ;; -(define (pgdb:update-test dbh test-id run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived last-update) +(define (pgdb:update-test dbh test-id run-id test-name item-path state status host cpuload diskfree uname run-dir log-file run-duration comment event-time archived last-update pid) (dbi:exec dbh "UPDATE tests SET - run_id=?,test_name=?,item_path=?,state=?,status=?,host=?,cpuload=?,diskfree=?,uname=?,rundir=?,final_logf=?,run_duration=?,comment=?,event_time=?,archived=?,last_update=? + run_id=?,test_name=?,item_path=?,state=?,status=?,host=?,cpuload=?,diskfree=?,uname=?,rundir=?,final_logf=?,run_duration=?,comment=?,event_time=?,archived=?,last_update=?,attemptnum=? WHERE id=?;" run-id test-name item-path state status host cpuload diskfree uname - run-dir log-file run-duration comment event-time archived last-update test-id)) + run-dir log-file run-duration comment event-time archived last-update pid test-id)) (define (pgdb:get-tests dbh target-patt) (dbi:get-rows dbh "SELECT t.id,t.run_id,t.test_name,t.item_path,t.state,t.status,t.host,t.cpuload,t.diskfree,t.uname,t.rundir,t.final_logf,t.run_duration,t.comment,t.event_time,t.archived, Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -643,31 +643,28 @@ ;; dot-locking egg seems not to work, using this for now ;; if lock is older than expire-time then remove it and try again ;; to get the lock ;; (define (common:simple-file-lock fname #!key (expire-time 300)) -; (handle-exceptions -; exn -; #f ;; don't really care what went wrong right now. NOTE: I have not seen this one actually fail. (if (common:file-exists? fname) (if (> (- (current-seconds)(file-modification-time fname)) expire-time) (begin - (delete-file* fname) + (handle-exceptions exn #f (delete-file* fname)) (common:simple-file-lock fname expire-time: expire-time)) #f) (let ((key-string (conc (get-host-name) "-" (current-process-id)))) (with-output-to-file fname (lambda () (print key-string))) (thread-sleep! 0.25) (if (common:file-exists? fname) - (with-input-from-file fname - (lambda () - (equal? key-string (read-line)))) - #f))) -; ) - ) + (handle-exceptions exn + #f + (with-input-from-file fname + (lambda () + (equal? key-string (read-line))))) + #f)))) (define (common:simple-file-lock-and-wait fname #!key (expire-time 300)) (let ((end-time (+ expire-time (current-seconds)))) (let loop ((got-lock (common:simple-file-lock fname expire-time: expire-time))) (if got-lock @@ -1880,11 +1877,11 @@ (max maxload-in 0.5))) ;; so maxload must be greater than 0.5 for now BUG - FIXME? (first (car loadavg)) (next (cadr loadavg)) (adjload (* maxload (max 1 numcpus))) ;; possible bug where numcpus (or could be maxload) is zero, crude fallback is to at least use 1 (loadjmp (- first next)) - (adjwait (min (+ 300 (random 10)) (* (+ (random 10)(/ (- 1000 count) 10) waitdelay) (- first adjload) ) ))) ;; add some randomness to the time to break any alignment where netbatch dumps many jobs to machines simultaneously + (adjwait (min (+ 300 (random 10)) (abs (* (+ (random 10)(/ (- 1000 count) 10) waitdelay) (- first adjload) )) ))) ;; add some randomness to the time to break any alignment where netbatch dumps many jobs to machines simultaneously (debug:print-info 1 *default-log-port* "Checking cpuload on " (or remote-host "localhost") ", maxload: " maxload ", load: " first ", adjload: " adjload ", loadjmp: " loadjmp) (cond ((and (> first adjload) (> count 0)) @@ -1978,10 +1975,20 @@ (let ((res (read-line))) (if (string? res) (string->number res))))) (get-unix-df path))) +(define (get-free-inodes path) + (if (configf:lookup *configdat* "setup" "free-inodes-script") + (with-input-from-pipe + (conc (configf:lookup *configdat* "setup" "free-inodes-script") " " path) + (lambda () + (let ((res (read-line))) + (if (string? res) + (string->number res))))) + (get-unix-inodes path))) + (define (get-unix-df path) (let* ((df-results (process:cmd-run->list (conc "df " path))) (space-rx (regexp "([0-9]+)\\s+([0-9]+)%")) (freespc #f)) ;; (write df-results) @@ -1991,10 +1998,24 @@ (let ((newval (string->number (cadr match)))) (if (number? newval) (set! freespc newval)))))) (car df-results)) freespc)) + +(define (get-unix-inodes path) + (let* ((df-results (process:cmd-run->list (conc "df -i " path))) + (space-rx (regexp "([0-9]+)\\s+([0-9]+)%")) + (freenodes #f)) + ;; (write df-results) + (for-each (lambda (l) + (let ((match (string-search space-rx l))) + (if match + (let ((newval (string->number (cadr match)))) + (if (number? newval) + (set! freenodes newval)))))) + (car df-results)) + freenodes)) (define (common:check-space-in-dir dirpath required) (let* ((dbspace (if (directory? dirpath) (get-df dirpath) 0))) @@ -2031,11 +2052,12 @@ ;; paths is list of lists ((name path) ... ) ;; (define (common:get-disk-with-most-free-space disks minsize) (let ((best #f) - (bestsize 0)) + (bestsize 0) + (min-inodes (or (string->number (if (configf:lookup *configdat* "setup" "min_inodes") (configf:lookup *configdat* "setup" "min_inodes") "0")) 0))) (for-each (lambda (disk-num) (let* ((dirpath (cadr (assoc disk-num disks))) (freespc (cond ((not (directory? dirpath)) @@ -2049,15 +2071,34 @@ ((not (eq? (string-ref dirpath 0) #\/)) (if (common:low-noise-print 300 "disks not a proper path " disk-num) (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it.")) -1) (else - (get-df dirpath))))) - (if (> freespc bestsize) + (get-df dirpath)))) + (free-inodes (cond + ((not (directory? dirpath)) + (if (common:low-noise-print 300 "disks not a dir " disk-num) + (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it.")) + -1) + ((not (file-write-access? dirpath)) + (if (common:low-noise-print 300 "disks not writeable " disk-num) + (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it.")) + -1) + ((not (eq? (string-ref dirpath 0) #\/)) + (if (common:low-noise-print 300 "disks not a proper path " disk-num) + (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it.")) + -1) + (else + (get-free-inodes dirpath)))) + ;;(free-inodes (get-free-inodes dirpath)) + ) + (if (and (> freespc bestsize)(> free-inodes min-inodes )) (begin (set! best (cons disk-num dirpath)) - (set! bestsize freespc))))) + (set! bestsize freespc))) + ;;(print "Processing: " disk-num " bestsize: " bestsize " best: " best " freespc: " freespc " min-inodes: " min-inodes " free-inodes: " free-inodes) + )) (map car disks)) (if (and best (> bestsize minsize)) best #f))) ;; #f means no disk candidate found Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1029,11 +1029,11 @@ ;; clear out junk records ;; ((dejunk) (db:delay-if-busy mtdb) ;; ok to delay on mtdb - (db:clean-up mtdb) + (when (file-write-access? (db:dbdat-get-path mtdb)) (db:clean-up mtdb)) (db:clean-up tmpdb) (db:clean-up refndb)) ;; sync runs, test_meta etc. ;; @@ -2693,11 +2693,11 @@ thekey)) ;; Get run-ids for runs with same target but different runnames and NOT run-id ;; (define (db:get-prev-run-ids dbstruct run-id) - (let* ((keyvals (rmt:get-key-val-pairs run-id)) + (let* ((keyvals (db:get-key-val-pairs dbstruct run-id)) (kvalues (map cadr keyvals)) (keys (rmt:get-keys)) (qrystr (string-intersperse (map (lambda (x)(conc x "=?")) keys) " AND "))) (let ((prev-run-ids '())) (if (null? keyvals) @@ -4086,11 +4086,11 @@ ((not (equal? calling-path *toppath*)) (list #f "Login failed due to mismatch paths: " calling-path ", " *toppath*)) ;; ((not (equal? *run-id* run-id)) ;; (list #f "Login failed due to mismatch run-id: " run-id ", " *run-id*)) ((not (equal? megatest-version calling-version)) - (list #f "Login failed due to mismatch megatest version: " calling-version ", " megatest-version)) + (list #t (conc "Login warning due to mismatch megatest version: " calling-version ", " megatest-version))) (else (hash-table-set! *logged-in-clients* client-signature (current-seconds)) '(#t "successful login")))) (define (db:general-call dbstruct stmtname params) @@ -4585,11 +4585,12 @@ 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) + (print run-qry) + (print test-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 ")" ))) )))))) 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.6530) +(define megatest-version 1.6535) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -189,11 +189,12 @@ -testdata-csv [categorypatt/]varpatt : dump testdata for given category Misc -start-dir path : switch to this directory before running megatest -contour cname : add a level of hierarcy to the linktree and run paths - -area-tag tagname : add a tag to an area while syncking to pgdb + -area-tag tagname : add a tag to an area while syncing to pgdb + -run-tag tagname : add a tag to a run while syncing to pgdb -rebuild-db : bring the database schema up to date -cleanup-db : remove any orphan records, vacuum the db -import-megatest.db : push data from megatest.db to cache db files in /tmp/$USER -sync-to-megatest.db : pull data from cache files in /tmp/$USER to megatest.db -sync-to dest : sync to new postgresql central style database @@ -312,10 +313,11 @@ "-run-patt" "-target-patt" "-contour" "-area-tag" "-area" + "-run-tag" "-server" "-transport" "-port" "-extract-ods" "-pathmod" @@ -380,12 +382,14 @@ "-rerun-clean" "-rerun-all" "-clean-cache" "-no-cache" "-cache-db" + "-cp-eventtime-to-publishtime" "-use-db-cache" "-prepend-contour" + ;; misc "-repl" "-lock" "-unlock" @@ -639,13 +643,11 @@ ;; handle a clean-cache request as early as possible ;; (if (args:get-arg "-clean-cache") (let ((toppath (launch:setup))) (set! *didsomething* #t) ;; suppress the help output. - (runs:clean-cache (or (getenv "MT_TARGET") - (args:get-arg "-target") - (args:get-arg "-remtarg")) + (runs:clean-cache (common:args-get-target) (args:get-arg "-runname") toppath))) (if (args:get-arg "-env2file") (begin @@ -1081,11 +1083,11 @@ (lambda (target runname keys keyvals) (operate-on 'kill-runs mode: #f) ))) (if (args:get-arg "-kill-rerun") - (let* ((target-patt (args:get-arg "-target")) + (let* ((target-patt (common:args-get-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) @@ -1824,11 +1826,12 @@ (db-host (assoc/default 'db-host cmdinfo)) (run-id (assoc/default 'run-id cmdinfo)) (itemdat (assoc/default 'itemdat cmdinfo)) (state (args:get-arg ":state")) (status (args:get-arg ":status")) - (target (args:get-arg "-target")) + ;;(target (args:get-arg "-target")) + (target (common:args-get-target)) (toppath (assoc/default 'toppath cmdinfo))) (change-directory toppath) (if (not target) (begin (debug:print-error 0 *default-log-port* "-target is required.") Index: mt-pg.sql ================================================================== --- mt-pg.sql +++ mt-pg.sql @@ -42,10 +42,11 @@ 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 run_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; @@ -80,14 +81,26 @@ CREATE TABLE IF NOT EXISTS area_tags ( id SERIAL PRIMARY KEY, tag_id INTEGER DEFAULT 0, area_id INTEGER DEFAULT 0, CONSTRAINT areatagconstraint UNIQUE (tag_id, area_id)); + +CREATE TABLE IF NOT EXISTS run_tags ( + id SERIAL PRIMARY KEY, + tag_id INTEGER DEFAULT 0, + run_id INTEGER DEFAULT 0, + CONSTRAINT areatagconstraint UNIQUE (tag_id, run_id)); + CREATE VIEW area_tag_view as 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 ; + +CREATE VIEW run_tag_view as +select r.id as rid, t.id as tid,tag_name from runs as r inner join run_tags as rt on rt.run_id = r.id +inner join tags as t on t.id = rt.tag_id ; + INSERT INTO areas (id,area_name,area_path) VALUES (0,'local','.'); CREATE TABLE IF NOT EXISTS ttype ( id SERIAL PRIMARY KEY, @@ -105,10 +118,11 @@ comment TEXT DEFAULT '', fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, last_update INTEGER DEFAULT extract(epoch from now()), area_id INTEGER DEFAULT 0, + publish_time INTEGER default date_part('epoch'::text, now()), 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, @@ -305,10 +319,17 @@ public INTEGER DEFAULT 0, search_patt TEXT default '.*', deleted INTEGER default 0 ); +CREATE TABLE IF NOT EXISTS flexviews( + id SERIAL PRIMARY KEY , + public INTEGER DEFAULT 0, + attributes TEXT NOT NULL, + name TEXT NOT NULL, + deleted INTEGER default 0 +); CREATE TABLE IF NOT EXISTS users_webviews( id SERIAL PRIMARY KEY , user_id INTEGER NOT NULL, Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -1127,11 +1127,14 @@ ;;(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) - ))))) (print "Skipping area: " area " and target: " runkey " due to packets-generated: " packets-generated " higher than " (configf:lookup mtconf "setup" "max_packets_per_run") ) ) ) (filter (lambda (x) (if (not (args:get-arg "-area")) #t (if (string= x (args:get-arg "-area")) #t #f))) all-areas)) + ))))) + (if (>= packets-generated (string->number (configf:lookup mtconf "setup" "max_packets_per_run"))) (print "Skipping area: " area " and target: " runkey " due to packets-generated: " packets-generated " higher than " (configf:lookup mtconf "setup" "max_packets_per_run")))) + + ) (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) @@ -1374,11 +1377,11 @@ (logf (conc logdir "/" uuid "-run.log")) (fullcmd (conc "NBFAKE_LOG=" logf " nbfake " cmdline))) (if (check-access user mtconf action area) (if (and (> cpuload maxload) (member action '("run" "archive"))) ;; do not run archive or run if load is over the specified limit - (print "WARNING: cpuload too high, skipping processing of " uuid) + (print "WARNING: cpuload too high, skipping processing of " uuid " due to " cpuload " > " maxload) (begin (print "RUNNING: " fullcmd) (system fullcmd) ;; replace with process ... (mark-processed pdb (list (alist-ref 'id pktdat))) (let-values (((ack-uuid ack-pkt) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -359,10 +359,14 @@ ;; return #t when all items in waitors-upon list are represented in test-patt, #f otherwise. (define (runs:testpatts-mention-waitors-upon? test-patt waitors-upon) (null? (tests:filter-test-names-not-matched waitors-upon test-patt))) +;;====================================================================== +;; runs:run-tests is called from megatest.scm and itself +;;====================================================================== +;; ;; test-names: Comma separated patterns same as test-patts but used in selection ;; of tests to run. The item portions are not respected. ;; FIXME: error out if /patt specified ;; (define (runs:run-tests target runname test-patts user flags #!key (run-count 1)) ;; test-names @@ -735,10 +739,14 @@ ;; tal - list of never visited tests ;; prefer next hed to be from reg than tal. (define runs:nothing-left-in-queue-count 0) +;;====================================================================== +;; runs:expand-items is called by runs:run-tests-queue +;;====================================================================== +;; ;; return value of runs:expand-items is passed back to runs-tests-queue and is fed to named loop with this signature: ;; (let loop ((hed (car sorted-test-names)) ;; (tal (cdr sorted-test-names)) ;; (reg '()) ;; registered, put these at the head of tal ;; (reruns '())) @@ -1315,10 +1323,14 @@ ;; every time though the loop increment the test/itempatt val. ;; when the min is > max-allowed and none running then force exit ;; (define *max-tries-hash* (make-hash-table)) +;;====================================================================== +;; runs:run-tests-queue is called by runs:run-tests +;;====================================================================== +;; ;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... > (define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in all-tests-registry) ;; At this point the list of parent tests is expanded ;; NB// Should expand items here and then insert into the run queue. (debug:print 5 *default-log-port* "test-records: " test-records ", flags: " (hash-table->alist flags)) @@ -1384,12 +1396,10 @@ (let loop ((hed (car sorted-test-names)) (tal (cdr sorted-test-names)) (reg '()) ;; registered, put these at the head of tal (reruns '())) - - (runs:incremental-print-results run-id) (if (not (null? reruns))(debug:print-info 4 *default-log-port* "reruns=" reruns)) ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes Index: subrun.scm ================================================================== --- subrun.scm +++ subrun.scm @@ -128,18 +128,18 @@ (kill-result (subrun:exec-sub-megatest test-run-dir action-switches-str "kill"))) kill-result) #t)) -(define (subrun:launch-cmd test-run-dir) +(define (subrun:launch-cmd test-run-dir #!optional (sub-cmd "-run")) ;; BUG: "-run" should be changed to "-rerun-clean" but current doesn't work (if (subrun:subrun-removed? test-run-dir) (subrun:unset-subrun-removed test-run-dir)) (let* ((log-prefix "run") (switches (subrun:selector+log-switches test-run-dir log-prefix)) (run-wait #t) - (cmd (conc "megatest -rerun-clean "switches" " + (cmd (conc "megatest " sub-cmd " " switches" " (if run-wait "-run-wait " "")))) cmd)) (define (subrun:sanitize-path inpath) Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -762,16 +762,22 @@ (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")))) + (run-tag (if (args:get-arg "-run-tag") + (args:get-arg "-run-tag") + "")) (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)) + (publish-time (if (args:get-arg "-cp-eventtime-to-publishtime") + event-time + (current-seconds))) (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 @@ -781,12 +787,14 @@ (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 last-update) - (debug:print-info 1 *default-log-port* "Working on run-id " run-id " pgdb-id " new-run-id ) + state status owner event-time comment fail-count pass-count area-id last-update publish-time) + (debug:print-info 0 *default-log-port* "Working on run-id " run-id " pgdb-id " new-run-id ) + (if (not (equal? run-tag "")) + (task:add-run-tag dbh new-run-id run-tag)) 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) @@ -793,20 +801,41 @@ (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 last-update)) + spec-id target run-name state status owner event-time comment fail-count pass-count area-id last-update publish-time)) (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 (task:add-run-tag dbh run-id tag) + (let* ((tag-info (pgdb:get-tag-info-by-name dbh tag))) + (if (not tag-info) + (begin + (if (handle-exceptions + exn + (begin + (debug:print-info 1 *default-log-port* ((condition-property-accessor 'exn 'message) exn)) + #f) + (pgdb:insert-tag dbh tag)) + (set! tag-info (pgdb:get-tag-info-by-name dbh tag)) + #f))) + ;;add to area_tags + (handle-exceptions + exn + (begin + (debug:print-info 1 *default-log-port* ((condition-property-accessor 'exn 'message) exn)) + #f) + (if (not (pgdb:is-run-taged-with-a-tag dbh (vector-ref tag-info 0) run-id)) + (pgdb:insert-run-tag dbh (vector-ref tag-info 0) run-id))))) + (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))) @@ -920,10 +949,11 @@ (test-name (db:test-get-testname test-info)) (item-path (db:test-get-item-path test-info)) (state (db:test-get-state test-info)) (status (db:test-get-status test-info)) (host (db:test-get-host test-info)) + (pid (db:test-get-process_id test-info)) (cpuload (db:test-get-cpuload test-info)) (diskfree (db:test-get-diskfree test-info)) (uname (db:test-get-uname test-info)) (run-dir (db:test-get-rundir test-info)) (log-file (db:test-get-final_logf test-info)) @@ -948,14 +978,14 @@ (begin ;; let ((key-name (conc run-id "/" test-name "/" item-path))) (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)) + (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 pid)) (begin (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) + (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 pid) (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.")))) @@ -1021,11 +1051,10 @@ ;(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 - ;(print "here") (if area-info (let* ((last-sync-time (vector-ref area-info 3)) (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) @@ -1038,11 +1067,10 @@ (area-tag (if (args:get-arg "-area-tag") (args:get-arg "-area-tag") (if (args:get-arg "-area") (args:get-arg "-area") "")))) - ;(print "here2") (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))) Index: tests/Makefile ================================================================== --- tests/Makefile +++ tests/Makefile @@ -16,11 +16,13 @@ # along with Megatest. If not, see . # # run some tests BINPATH = $(shell readlink -m $(PWD)/../bin) +LSBR = $(shell lsb_release -sr) MEGATEST = $(BINPATH)/megatest +MTEST = $(BINPATH)/.$(LSBR)/mtest DASHBOARD = $(BINPATH)/dashboard PATH := $(BINPATH):$(PATH) RUNNAME := $(shell date +w%V.%u.%H.%M) IPADDR := "-" RUNID := 1 @@ -38,20 +40,23 @@ TARGET = "ubuntu/nfs/none" all : build unit test4 # test1 test2 test3 test4 test5 test6 test7 test8 test9 -unit : all-rmt.log +unit : all-rmt.log all-api.log # basicserver.log runs.log misc.log tests.log + +# inter dependencies on the unit tests, I wish these could be "suggestions" +all-rmt.log : all-api.log rel : cd release;dashboard -rows 25 & ## basicserver.log : unittests/basicserver.scm ## script -c "./rununittest.sh basicserver $(DEBUG)" basicserver.log -%.log : build unittests/%.scm +%.log : build unittests/%.scm $(MTEST) script -c "./rununittest.sh $* $(DEBUG)" $*.log if logpro unit.logpro $*.html < $*.log > /dev/null;then echo ALLPASS;else echo ALLFAIL;mv $*.log $*.log.FAIL;fi server : cd fullrun;$(MEGATEST) -server - -debug $(DEBUG) -run-id $(RUNID) @@ -103,11 +108,11 @@ cd fullrun;sleep 5;$(MEGATEST) -preclean -runtests % -target ubuntu/nfs/sleep60 :runname $(RUNNAME)_ac -debug $(DEBUG) $(LOGGING) > ac.log 2> ac.log & cd fullrun;sleep 8;$(MEGATEST) -preclean -runtests % -target ubuntu/nfs/sleep240 :runname $(RUNNAME)_ad -debug $(DEBUG) $(LOGGING) > ad.log 2> ad.log & # cd fullrun;sleep 0;$(MEGATEST) -preclean -runtests % -target $(TARGET) :runname $(RUNNAME)_af -debug $(DEBUG) $(LOGGING) > af.log 2> af.log & # MUST ADD THIS BACK IN ASAP!!!! - # cd fullrun;sleep 10;$(MEGATEST) -run-wait -target $(TARGET) :runname % -testpatt % :state RUNNING,LAUNCHED,NOT_STARTED,REMOTEHOSTSTART;echo ALL DONE +# cd fullrun;sleep 10;$(MEGATEST) -run-wait -target $(TARGET) :runname % -testpatt % :state RUNNING,LAUNCHED,NOT_STARTED,REMOTEHOSTSTART;echo ALL DONE test6: fullprep cd fullrun;$(MEGATEST) -preclean -runtests runfirst -testpatt %/1 -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -v cd fullrun;$(MEGATEST) -preclean -runtests runfirst -testpatt %blahha% -reqtarg ubuntu/nfs/none :runname $(RUNNAME)_itempatt -debug 10 cd fullrun;$(MEGATEST) -rollup :runname newrun -target ubuntu/nfs/none -debug 10 Index: tests/rununittest.sh ================================================================== --- tests/rununittest.sh +++ tests/rununittest.sh @@ -28,11 +28,11 @@ # Clean setup # dbdir=$(echo /tmp/$USER/megatest_localdb/simplerun/.[a-zA-Z]*/) echo "dbdir=$dbdir" -rm -f simplerun/megatest.db simplerun/monitor.db simplerun/db/monitor.db $dbdir +rm -f simplerun/megatest.db simplerun/monitor.db simplerun/db/monitor.db rm -rf simplelinks/ simpleruns/ simplerun/db/ $dbdir mkdir -p simplelinks simpleruns (cd simplerun;cp ../../*_records.scm .;perl -pi.bak -e 's/define-inline/define/' *_records.scm) (cd simplerun;cp ../../altdb.scm .) ADDED tests/unittests/all-api.scm Index: tests/unittests/all-api.scm ================================================================== --- /dev/null +++ tests/unittests/all-api.scm @@ -0,0 +1,176 @@ + +;;====================================================================== +;; A L L - A P I +;;====================================================================== + +;; Copyright 2006-2017, Matthew Welland. +;; +;; This file is part of Megatest. +;; +;; Megatest is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; Megatest is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with Megatest. If not, see . + + +;; Run like this: +;; +;; Update the following line. make unit from parent directory. +;; ./rununittest.sh all-api 1 + +;; Definitions: +;; NTN - no test needed +;; DEP - function is deprecated, no point in testing +;; NED - function nested under others, no test needed. +;; DEF - deferred + + +;; Issues: +;; 1. Most of the API calls accept a string or symbol for the function name, but at least one requires a symbol. +;; Should we decide one way or the other, symbol or string, (seems symbol is best) and enforce that in the API? Current code: +;; (cmd (if (symbol? cmd-in) +;; cmd-in +;; (string->symbol cmd-in))) +;; Just accept symbol +;; In the refactor, change execute-requests to only accept a symbol. + +;; 2. Some functions return in element 1 of the vector. What to do about this? Fix them to return a measurable value? +;; Or is there a way to make test accept ? - No. +;; This is why I had to use vector-ref and look at one value or the other. +;; Look at why functions are returning unspecified. +;; The last function they call returns nothing. + +;; 3. Some API functions call non-existent db functions. +;; Delete these API functions after checking that they are not called? +;; Comment them out and give a date to delete. (in the refactor branch?) + +;; 4. get-tests-times: no such query supported in api.scm, but it is in the list of read-only queries. Remove it? Or implement it if it's in db.scm? + + +(define my-dbstruct (db:setup #t)) +(define toppath (current-directory)) +(define keypatts '(("SYSTEM" "ubuntu")("RELEASE" "v1.234")) ) +(define keys (db:get-keys my-dbstruct)) + +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'start-server (list *toppath* ))) 0)) +(test #f '() (vector-ref (api:execute-requests my-dbstruct (vector 'get-key-val-pairs (list 0 ))) 1)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'set-var (list "LAST_UPDATE" 1234567))) 0)) +(test #f 1234567 (vector-ref (api:execute-requests my-dbstruct (vector 'get-var (list "LAST_UPDATE" ))) 1)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'del-var (list "LAST_UPDATE" ))) 0)) +(test #f '("SYSTEM" "RELEASE") (vector-ref (api:execute-requests my-dbstruct (vector 'get-keys (list ))) 1)) +(test #f '() (vector-ref (api:execute-requests my-dbstruct (vector 'get-key-vals (list 1 ))) 1)) +(test #f 0 (vector-ref (api:execute-requests my-dbstruct (vector 'test-toplevel-num-items (list 1 "foo"))) 1)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-test-info-by-id (list 1 1))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-steps-info-by-id (list 1))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-data-info-by-id (list 1))) 0)) +(test #f '(#t "successful login") (vector-ref (api:execute-requests my-dbstruct (vector 'login (list toppath megatest-version "Fred"))) 1)) +(test #f '(-1 . 0) (vector-ref (api:execute-requests my-dbstruct (vector 'get-latest-host-load (list "localhost"))) 1)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-changed-record-ids (list 0))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-run-record-ids (list "%" 1 keys "%/%"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-not-completed-cnt (list 1))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-tests-tags (list ))) 0)) +;; no such query supported in api.scm, but it is is the list of read-only queries. +;;(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-tests-times (list ))) 0)) +(test #f '("SYSTEM" "RELEASE") (vector-ref (api:execute-requests my-dbstruct (vector 'get-keys-write (list ))) 1)) +(test #f (vector '("SYSTEM" "RELEASE") '())(vector-ref (api:execute-requests my-dbstruct (vector 'get-targets (list 1 ))) 1)) +(test #f "" (vector-ref (api:execute-requests my-dbstruct (vector 'get-target (list 1 ))) 1)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'general-call (list 'register-test 1 1 "foo" ""))) 0)) +(test #f 1 (vector-ref (api:execute-requests my-dbstruct (vector 'get-test-id (list 1 "foo" ""))) 1)) +(test #f "/tmp/badname" (vector-ref (api:execute-requests my-dbstruct (vector 'test-get-rundir-from-test-id (list 1 1))) 1)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'set-tests-state-status (list 1 '("foo") "COMPLETED" "PASS" "NOT_STARTED" "PASS"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'test-set-state-status-by-id (list 1 1 "COMPLETED" "PASS" "Just testing!"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-tests-for-run (list 1 "%" '() '() #f #f #f #f #f #f 0 #f))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-tests-for-run-mindata (list 1 "%" '("COMPLETED") '("PASS") #f ))) 0)) +;; api.scm calls db:get-tests-for-runs-mindata, which does not exist. +;;(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-tests-for-runs-mindata (list 1 "%" '("COMPLETED") '("PASS") #f ))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'delete-test-records (list 1 2 ))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'test-set-state-status (list 1 1 "COMPLETED" "FAIL" "Another message" ))) 0)) +;; api.scm calls db:get-previous-test-run-record, which does not exist. +;;(test #f '() (vector-ref (api:execute-requests my-dbstruct (vector "get-previous-test-run-record" (list 1 ))) 1)) +(test #f '() (vector-ref (api:execute-requests my-dbstruct (vector 'get-matching-previous-test-run-records (list 1 "foo" ""))) 1)) +(test #f '("/tmp/badname" "logs/final.log") (vector-ref (api:execute-requests my-dbstruct (vector 'test-get-logfile-info (list 1 "foo"))) 1)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'test-get-records-for-index-file (list 1 "foo"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-testinfo-state-status (list 1 1))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'general-call (list 'test-set-log 1 "/tmp/another/logfile/eh" 1))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'test-set-archive-block-id (list 1 1 123))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'test-set-top-process-pid (list 1 1 123))) 0)) +(test #f 123 (vector-ref (api:execute-requests my-dbstruct (vector 'test-get-top-process-pid (list 1 1))) 1)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-run-ids-matching-target (list keys "%/%" #f "%" "%" "%" "%"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'test-get-paths-matching-keynames-target-new (list 1 keys "%/%" #f "%" "%" "%" "%"))) 0)) +(test #f '() (vector-ref (api:execute-requests my-dbstruct (vector 'get-prereqs-not-met (list 1 '() "foo" "" '(normal) '()))) 1)) +(test #f 0 (vector-ref (api:execute-requests my-dbstruct (vector 'get-count-tests-running-for-run-id (list 1))) 1)) +(test #f 0 (vector-ref (api:execute-requests my-dbstruct (vector 'get-count-tests-running (list 1))) 1)) +(test #f 0 (vector-ref (api:execute-requests my-dbstruct (vector 'get-count-tests-running-for-testname (list 1 "foo"))) 1)) +(test #f 0 (vector-ref (api:execute-requests my-dbstruct (vector 'get-count-tests-running-in-jobgroup (list 1 "nada"))) 1)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'set-state-status-and-roll-up-items (list 1 "foo" "" "COMPLETED" "FAIL" "Just yet another message"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'set-state-status-and-roll-up-run (list 1 "COMPLETED" "FAIL"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'top-test-set-per-pf-counts (list 1 "foo"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-raw-run-stats (list 1))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-run-info (list 1))) 0)) +(test #f 0 (vector-ref (api:execute-requests my-dbstruct (vector 'get-num-runs (list "%"))) 1)) +(test #f 0 (vector-ref (api:execute-requests my-dbstruct (vector 'get-runs-cnt-by-patt (list "%" "%/%" keys))) 1)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'register-run (list '(("SYSTEM" "ubuntu")("RELEASE" "v1.234")) "bar" "NEW" "JUSTFINE" "bobafett" "quick" ))) 0)) +(test #f #(#t "bar") (api:execute-requests my-dbstruct (vector 'get-run-name-from-id '(1)))) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'delete-run (list 2))) 0)) ;; delete a non-existant run +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'update-run-stats (list 1 '()))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-main-run-stats (list 1 ))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'delete-old-deleted-test-records '())) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-runs (list "%" 10 0 keypatts))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'simple-get-runs (list "%" 10 0 keypatts))) 0)) +(test #f #(#t (1))(api:execute-requests my-dbstruct (vector 'get-all-run-ids '()))) +(test #f #(#t ()) (api:execute-requests my-dbstruct (vector 'get-prev-run-ids '(1)))) +(test #f #(#t "JUSTFINE") (api:execute-requests my-dbstruct (vector 'get-run-status '(1)))) +(test #f #(#t "NEW") (api:execute-requests my-dbstruct (vector 'get-run-state '(1)))) +(test #f #(#t (("Totals" "UNKNOWN" 1) ("bar" "UNKNOWN" 1))) (api:execute-requests my-dbstruct (vector 'get-run-stats '()))) +(test #f #(#t ()) (api:execute-requests my-dbstruct (vector 'get-run-times '(1 1 )))) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'lock/unlock-run '(1 #t #f "mikey"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'set-run-status '(1 "NOTFINE" "A message"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'set-run-state-status '(1 "NOTFINE" "AMESS"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'update-run-event_time '(1))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-runs-by-patt (list keys "%" "%/%" #f #f #f #f "ASC"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-steps-data (list 1 1))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'get-steps-for-test (list 1 1))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'delete-steps-for-test! (list 1 1))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'teststep-set-status! (list 1 1 "step1" "COMPLETED" "PASS" "force pass" "/tmp/logfile"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'test-data-rollup (list 1 1 "COMPLETED"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'csv->test-data (list 1 1 "some,data"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'read-test-data (list 1 1 "%"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'read-test-data* (list 1 1 "%" "%"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'tasks-add (list "run" "Fred" "%" "foo" "%/%" #f))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'tasks-set-state-given-param-key (list "mykey" "COMPLETED"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'tasks-get-last (list "%" "foo"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'find-task-queue-records (list "%" "myrun" "%/%" "RUNNING" "run"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'testmeta-add-record (list "foo"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'testmeta-update-field (list "foo" "description" "junk"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'testmeta-get-record (list "foo"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'have-incompletes? (list 1 12000))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'mark-incomplete (list 1 12000))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'no-sync-set (list "field1" "value1"))) 0)) +(test #f "value1" (vector-ref (api:execute-requests my-dbstruct (vector 'no-sync-get/default (list "field1" #f))) 1)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'no-sync-del! (list "field1"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'no-sync-get-lock (list "mykey"))) 0)) +(test #f 1 (vector-ref (api:execute-requests my-dbstruct (vector 'archive-register-disk (list "mydisk" "/usr/mydisk" 10000000))) 1)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'archive-register-block-name (list 1 "/usr/mydisk/myblock"))) 0)) +;;This api function calls db:archive-allocate-testsuite/area-to-block, which does not exist. +;;(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'archive-allocate-testsuite/area-to-block (list 1 "/usr/mydisk/myblock"))) 0)) +(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'test-get-archive-block-info (list 1 ))) 0)) + +;;debug this: ERROR: parameter last-update for db:sync-tables must be a pair or a number, received: (0 . last_update) +;;(test #f #t (vector-ref (api:execute-requests my-dbstruct (vector 'sync-inmem->db (list 1))) 0)) + +;;debug this. Error: bad argument count - received 0 but expected 5: #alist (rmt:get-tests-tags)) equal?) string<=)) - +(test #f '("test1" "test2")(sort (alist-ref "tagtwo" (rmt:get-tests-tags) equal?) string<=)) (test #f '() (rmt:get-key-val-pairs 0)) (test #f '("SYSTEM" "RELEASE") (rmt:get-keys)) (test #f '("SYSTEM" "RELEASE") (rmt:get-keys-write)) ;; dummy query to force server start (test #f '() (rmt:get-key-vals 1)) (test #f (vector '("SYSTEM" "RELEASE") '()) (rmt:get-targets)) @@ -71,11 +103,11 @@ (test #f "" (rmt:get-target 1)) (test #f #t (rmt:register-test 1 "foo" "")) (test #f 1 (rmt:get-test-id 1 "foo" "")) (test #f "foo" (vector-ref (rmt:get-test-info-by-id 1 1) 2)) (test #f "/tmp/badname" (rmt:test-get-rundir-from-test-id 1 1)) -(test #f '(1) (db:set-tests-state-status *db* 1 '("foo") "COMPLETED" "PASS" "NOT_STARTED" "PASS")) +;; (test #f '(1) (db:set-tests-state-status *db* 1 '("foo") "COMPLETED" "PASS" "NOT_STARTED" "PASS")) ;; trust that this was tested in all-api (test #f '(1) (rmt:set-tests-state-status 1 '("foo") "COMPLETED" "PASS" "NOT_STARTED" "PASS")) (test #f #t (mt:test-set-state-status-by-id 1 1 "COMPLETED" "PASS" "Just testing!")) (test #f #t (list? (rmt:get-tests-for-run 1 "%" '() '() #f #f #f #f #f #f 0 #f))) (test #f #t (list? (rmt:get-tests-for-runs-mindata '(1) "%" '() '() #f))) (test #f #f (begin (rmt:delete-test-records 1 2) #f)) @@ -129,10 +161,25 @@ ;; (print "rmt:get-runs-by-patt returned: " res) (and (vector? res) (let ((rows (vector-ref res 1))) (> (length rows) 0)))))) + +(test #f '(("Totals" "UNKNOWN" 1) ("bar" "UNKNOWN" 1)) (begin (rmt:get-run-stats))) +(test #f #t (begin (rmt:set-run-state-status 1 "COMPLETE" "PASS") #t)) +(test #f '"COMPLETE" (rmt:get-run-state 1)) +(test #f '"PASS" (rmt:get-run-status 1)) +(test #f #t (begin (rmt:set-var "foo" "bar")#t)) +(test #f "bar" (rmt:get-var "foo")) +(test #f #t (begin (rmt:print-db-stats) #t)) +(test #f #t (begin (rmt:del-var "foo") #t)) +(test #f #f (rmt:get-var "foo")) +(test #f (vector #f #f #f #f #f #f #f #f #f #f #f #f) (rmt:get-data-info-by-id 1)) +(test #f '() (rmt:get-key-vals 1)) +(test #f "ubuntu/v1.234" (rmt:get-target 1)) +(print (rmt:get-run-info 1)) +(test #f '((runs) (tests) (test_steps) (test_data)) (rmt:get-run-record-ids "ubuntu/v1.234" 1 '("fail_count") "bar")) ;; (rmt:find-and-mark-incomplete run-id ovr-deadtime) ;; (rmt:get-main-run-stats run-id) ;; (rmt:get-var varname) ;; (rmt:set-var varname value) ;; (rmt:find-and-mark-incomplete-all-runs #!key (ovr-deadtime #f))