Overview
Comment: | More minor fixes and cleanup. |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.65-real |
Files: | files | file ages | folders |
SHA1: |
259b439f9458a0b3d545819e4abe024c |
User & Date: | matt on 2021-02-14 20:26:08 |
Other Links: | branch diff | manifest | tags |
Context
2021-02-14
| ||
22:33 | Synced minor changes from modularized v1.6569-mult-db-wip branch check-in: f8657e116c user: matt tags: v1.65-real | |
20:26 | More minor fixes and cleanup. check-in: 259b439f94 user: matt tags: v1.65-real | |
19:54 | Bunch of minor fixes/cleanup check-in: 4aae235143 user: matt tags: v1.65-real | |
Changes
Modified api.scm from [40d8c4509c] to [7029eb2f68].
︙ | ︙ | |||
74 75 76 77 78 79 80 | get-all-run-ids get-prev-run-ids get-run-ids-matching-target get-runs-by-patt get-steps-data get-steps-for-test read-test-data | | | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 | get-all-run-ids get-prev-run-ids get-run-ids-matching-target get-runs-by-patt get-steps-data get-steps-for-test read-test-data read-test-data-varpatt login tasks-get-last testmeta-get-record have-incompletes? ;; synchash-get get-changed-record-ids get-run-record-ids |
︙ | ︙ | |||
327 328 329 330 331 332 333 | ;; STEPS ((get-steps-data) (apply db:get-steps-data dbstruct params)) ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) ((get-steps-info-by-id) (apply db:get-steps-info-by-id dbstruct params)) ;; TEST DATA ((read-test-data) (apply db:read-test-data dbstruct params)) | | | 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 | ;; STEPS ((get-steps-data) (apply db:get-steps-data dbstruct params)) ((get-steps-for-test) (apply db:get-steps-for-test dbstruct params)) ((get-steps-info-by-id) (apply db:get-steps-info-by-id dbstruct params)) ;; TEST DATA ((read-test-data) (apply db:read-test-data dbstruct params)) ((read-test-data-varpatt) (apply db:read-test-data-varpatt dbstruct params)) ((get-data-info-by-id) (apply db:get-data-info-by-id dbstruct params)) ;; MISC ((get-latest-host-load) (apply db:get-latest-host-load dbstruct params)) ((have-incompletes?) (apply db:have-incompletes? dbstruct params)) ((login) (apply db:login dbstruct params)) ((general-call) (let ((stmtname (car params)) |
︙ | ︙ |
Modified common.scm from [77edf68a77] to [68ebb4e66e].
︙ | ︙ | |||
245 246 247 248 249 250 251 | ((dboard) (conc updir progname)) ((mtest) (conc updir progname)) ((dashboard) progname) (else exe))))) '("../../" "../"))))) (if (null? res) (begin | | | 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 | ((dboard) (conc updir progname)) ((mtest) (conc updir progname)) ((dashboard) progname) (else exe))))) '("../../" "../"))))) (if (null? res) (begin (debug:print 0 *default-log-port* "Failed to find this executable! Using what can be found on the path") progname) (car res)))) (define *common:logpro-exit-code->status-sym-alist* '( ( 0 . pass ) ( 1 . fail ) ( 2 . warn ) |
︙ | ︙ | |||
906 907 908 909 910 911 912 | (define (common:get-testsuite-name) (or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description. (configf:lookup *configdat* "setup" "testsuite" ) (getenv "MT_TESTSUITE_NAME") (pathname-file (or (if (string? *toppath* ) (pathname-file *toppath*) #f) | | | 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 | (define (common:get-testsuite-name) (or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description. (configf:lookup *configdat* "setup" "testsuite" ) (getenv "MT_TESTSUITE_NAME") (pathname-file (or (if (string? *toppath* ) (pathname-file *toppath*) #f) (common:get-toppath #f))) "please-set-setup-area-name")) ;; (pathname-file (current-directory))))) ;; safe getting of toppath (define (common:get-toppath areapath) (or *toppath* (if areapath (begin |
︙ | ︙ | |||
1311 1312 1313 1314 1315 1316 1317 | (handle-exceptions exn (begin (if message (debug:print-info 0 *default-log-port* message)) #f) (thunk) )) (define (common:file-exists? path-string #!key (silent #f)) | < < | | | 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 | (handle-exceptions exn (begin (if message (debug:print-info 0 *default-log-port* message)) #f) (thunk) )) (define (common:file-exists? path-string #!key (silent #f)) ;;;; TODO: catch permission denied exceptions and emit appropriate warnings. Might be able to get rid of with chicken 5? (common:false-on-exception (lambda () (file-exists? path-string)) message: (if (not silent) (conc "Unable to access path: " path-string) #f) )) (define (common:directory-exists? path-string) ;;;; TODO: catch permission denied exceptions and emit appropriate warnings (common:false-on-exception (lambda () (directory-exists? path-string)) message: (conc "Unable to access path: " path-string) )) ;; does the directory exist and do we have write access? ;; ;; returns the directory or #f |
︙ | ︙ | |||
1802 1803 1804 1805 1806 1807 1808 | ;; get values from cached info from dropping file in logs dir ;; e.g. key is host and dtype is normalized-load ;; (define (common:get-cached-info key dtype #!key (age 10)) (if *toppath* (let* ((fullpath (conc *toppath* "/.sysdata/" key "-" dtype ".log")) | | | 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 | ;; get values from cached info from dropping file in logs dir ;; e.g. key is host and dtype is normalized-load ;; (define (common:get-cached-info key dtype #!key (age 10)) (if *toppath* (let* ((fullpath (conc *toppath* "/.sysdata/" key "-" dtype ".log")) (delfile (lambda (exn) (debug:print-info 1 *default-log-port* " removing bad file " fullpath ", exn=" exn) (delete-file* fullpath) #f))) (if (and (file-exists? fullpath) (file-read-access? fullpath)) (handle-exceptions exn |
︙ | ︙ | |||
1825 1826 1827 1828 1829 1830 1831 | (debug:print 1 *default-log-port* "Failed to read mod time on file " fullpath ", using 0, exn=" exn) 0) (file-change-time fullpath))))) (if (< real-age age) (handle-exceptions exn | | | | 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 | (debug:print 1 *default-log-port* "Failed to read mod time on file " fullpath ", using 0, exn=" exn) 0) (file-change-time fullpath))))) (if (< real-age age) (handle-exceptions exn (delfile exn) (let* ((res (with-input-from-file fullpath read))) (if (eof-object? res) (begin (delfile "n/a") #f) res))) (begin (debug:print-info 2 *default-log-port* "file " fullpath " is too old (" real-age" seconds) to trust, skipping reading it") #f)))) (begin |
︙ | ︙ |
Modified db.scm from [403ca6d39a] to [f8288fb75d].
︙ | ︙ | |||
3050 3051 3052 3053 3054 3055 3056 | -1 "-" "-")) ;; ;; 1. cache tests-match-qry ;; 2. compile qry and store in hash ;; 3. convert for-each-row to fold ;; | | | | | | | | | | | | | | | | | | | | | | | | | 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 | -1 "-" "-")) ;; ;; 1. cache tests-match-qry ;; 2. compile qry and store in hash ;; 3. convert for-each-row to fold ;; ;; (define (db:get-tests-for-run-state-status dbstruct run-id testpatt) ;; (db:with-db ;; dbstruct run-id #f ;; (lambda (db) ;; (let* ((res '()) ;; (stmt-cache (dbr:dbstruct-stmt-cache dbstruct)) ;; (stmth (let* ((sh (db:hoh-get stmt-cache db testpatt))) ;; (or sh ;; (let* ((tests-match-qry (tests:match->sqlqry testpatt)) ;; (qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " ;; (if tests-match-qry (conc " AND (" tests-match-qry ") ") ""))) ;; (newsh (sqlite3:prepare db qry))) ;; (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry) ;; (db:hoh-set! stmt-cache db testpatt newsh) ;; newsh))))) ;; (reverse ;; (sqlite3:fold-row ;; (lambda (res id testname item-path state status) ;; ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment ;; (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res)) ;; '() ;; stmth ;; run-id)))))) (define (db:get-tests-for-run-state-status dbstruct run-id testpatt #!optional (last-update 0)) (let* ((res '()) (tests-match-qry (tests:match->sqlqry testpatt)) (qry (conc "SELECT id,testname,item_path,state,status,event_time,run_duration FROM tests WHERE run_id=? " " AND last_update > ? " (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") |
︙ | ︙ | |||
3551 3552 3553 3554 3555 3556 3557 | (lambda (test-name item-path test-time target ) (set! res (cons (vector test-name item-path test-time) res))) db qry run-name target) res)))) | < < < < < < < < < < < < < < < < < | 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 | (lambda (test-name item-path test-time target ) (set! res (cons (vector test-name item-path test-time) res))) db qry run-name target) res)))) ;;====================================================================== ;; S T E P S ;;====================================================================== (define (db:teststep-set-status! dbstruct run-id test-id teststep-name state-in status-in comment logfile) (db:with-db dbstruct |
︙ | ︙ | |||
3848 3849 3850 3851 3852 3853 3854 | (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, :read-test-data ;; | | | 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 | (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, :read-test-data ;; (define (db:read-test-data-varpatt dbstruct run-id test-id categorypatt varpatt) (let* ((res '())) (db:with-db dbstruct #f #f (lambda (db) (sqlite3:for-each-row (lambda (id test_id category variable value expected tol units comment status type) (set! res (cons (vector id test_id category variable value expected tol units comment status type) res))) |
︙ | ︙ |
Modified megatest.scm from [799fcfd358] to [35ed864745].
︙ | ︙ | |||
1326 1327 1328 1329 1330 1331 1332 | (test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test)) (testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test)) (itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test)) (fullname (conc testname (if (equal? itempath "") "" (conc "/" itempath )))) | | | 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 | (test-id (if (member "id" tests-spec)(get-value-by-fieldname test test-field-index "id" ) #f)) ;; (db:test-get-id test)) (testname (if (member "testname" tests-spec)(get-value-by-fieldname test test-field-index "testname" ) #f)) ;; (db:test-get-testname test)) (itempath (if (member "item_path" tests-spec)(get-value-by-fieldname test test-field-index "item_path" ) #f)) ;; (db:test-get-item-path test)) (fullname (conc testname (if (equal? itempath "") "" (conc "/" itempath )))) (testdat-raw (map vector->list (rmt:read-test-data-varpatt run-id test-id categorypatt setvarpatt))) (testdat (filter (lambda (x) (not (equal? "logpro" (list-ref x 10)))) testdat-raw))) (map (lambda (item) |
︙ | ︙ |
Modified rmt.scm from [bcbb74efcc] to [04632aa2df].
︙ | ︙ | |||
888 889 890 891 892 893 894 | ;;====================================================================== ;; T E S T D A T A ;;====================================================================== (define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) (rmt:send-receive 'read-test-data run-id (list run-id test-id categorypatt))) | > | | | 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 | ;;====================================================================== ;; T E S T D A T A ;;====================================================================== (define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) (rmt:send-receive 'read-test-data run-id (list run-id test-id categorypatt))) (define (rmt:read-test-data-varpatt run-id test-id categorypatt varpatt #!key (work-area #f)) (rmt:send-receive 'read-test-data-varpatt run-id (list run-id test-id categorypatt varpatt))) (define (rmt:get-data-info-by-id test-data-id) (rmt:send-receive 'get-data-info-by-id #f (list test-data-id))) (define (rmt:testmeta-add-record testname) (rmt:send-receive 'testmeta-add-record #f (list testname))) |
︙ | ︙ |