Overview
Comment: | wip |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.80-revolution-remodularization |
Files: | files | file ages | folders |
SHA1: |
8ff5e2e3a3b43b0c2ca33b8ef35c8742 |
User & Date: | matt on 2024-02-02 20:19:03 |
Other Links: | branch diff | manifest | tags |
Context
2024-02-02
| ||
20:54 | wip check-in: c1b66a127b user: matt tags: v1.80-revolution-remodularization | |
20:19 | wip check-in: 8ff5e2e3a3 user: matt tags: v1.80-revolution-remodularization | |
2024-02-01
| ||
21:13 | More munging for remodularization check-in: ab8f9725fd user: matt tags: v1.80-revolution-remodularization | |
Changes
Modified Makefile from [2a6def2c4a] to [99d28b9662].
︙ | ︙ | |||
36 37 38 39 40 41 42 | subrun.scm archive.scm env.scm \ diff-report.scm cgisetup/models/pgdb.scm # module source files MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm \ tcp-transportmod.scm rmtmod.scm portlogger.scm apimod.scm \ configfmod.scm processmod.scm servermod.scm megatestmod.scm \ | | > > | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | subrun.scm archive.scm env.scm \ diff-report.scm cgisetup/models/pgdb.scm # module source files MSRCFILES = dbfile.scm debugprint.scm mtargs.scm commonmod.scm dbmod.scm \ tcp-transportmod.scm rmtmod.scm portlogger.scm apimod.scm \ configfmod.scm processmod.scm servermod.scm megatestmod.scm \ stml2.scm fsmod.scm cpumod.scm mtmod.scm odsmod.scm tasksmod.scm \ pkts.scm transport-mode.scm : transport-mode.scm.template cp transport-mode.scm.template transport-mode.scm dashboard-transport-mode.scm : dashboard-transport-mode.scm.template cp dashboard-transport-mode.scm.template dashboard-transport-mode.scm mtest : transport-mode.scm dboard : dashboard-transport-mode.scm # dbmod.import.o is just a hack here process.o : mofiles/processmod.o mofiles/configfmod.o : mofiles/processmod.o mofiles/processmod.o : mofiles/commonmod.o mofiles/servermod.o : mofiles/commonmod.o mofiles/rmtmod.o : mofiles/mtmod.o mofiles/apimod.o mofiles/dbmod.o : mofiles/mtmod.o # mofiles/mtmod.o : mofiles/tcp-transportmod.o mofiles/megatestmod.o : mofiles/pkts.o mofiles/dbfile.o : \ mofiles/debugprint.o mofiles/commonmod.o mofiles/configfmod.o mofiles/apimod.o : mofiles/commonmod.o mofiles/tcp-transportmod.o mofiles/configfmod.o mofiles/megatestmod.o mofiles/rmtmod.o : mofiles/tasksmod.o mofiles/dbmod.o : mofiles/dbfile.o mofiles/api.o : mofiles/apimod.o |
︙ | ︙ |
Modified megatestmod.scm from [50b6929265] to [9d20f007d1].
︙ | ︙ | |||
27 28 29 30 31 32 33 34 35 36 37 38 39 40 | (declare (unit megatestmod)) (declare (uses debugprint)) (declare (uses mtargs)) (declare (uses dbmod)) (declare (uses dbfile)) (declare (uses commonmod)) (declare (uses configfmod)) (use srfi-69) (module megatestmod * (import scheme) | > > > | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | (declare (unit megatestmod)) (declare (uses debugprint)) (declare (uses mtargs)) (declare (uses dbmod)) (declare (uses dbfile)) (declare (uses commonmod)) (declare (uses configfmod)) (declare (uses processmod)) (declare (uses mtmod)) (declare (uses pkts)) (use srfi-69) (module megatestmod * (import scheme) |
︙ | ︙ | |||
90 91 92 93 94 95 96 | chicken.time chicken.time.posix matchable md5 message-digest pathname-expand | > > > > | | > | > > > > > > > > | | | 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 | chicken.time chicken.time.posix matchable md5 message-digest pathname-expand system-information ))) (import regex regex-case srfi-1 srfi-18 srfi-69 typed-records directory-utils call-with-environment-variables commonmod configfmod debugprint dbmod dbfile processmod mtmod pkts ) ;;====================================================================== ;; '(print (string-intersperse (map cadr (hash-table-ref/default (read-config "megatest.config" \#f \#t) "disks" '"'"'("none" ""))) "\n"))' (define (common:get-disks #!key (configf #f)) (hash-table-ref/default (or configf (read-config "megatest.config" #f #t)) "disks" '("none" ""))) |
︙ | ︙ | |||
792 793 794 795 796 797 798 | (define (runconfigs-get config var) (let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET")))) (if targ (or (configf:lookup config targ var) (configf:lookup config "default" var)) (configf:lookup config "default" var)))) | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 | (define (runconfigs-get config var) (let ((targ (common:args-get-target))) ;; (or (args:get-arg "-reqtarg")(args:get-arg "-target")(getenv "MT_TARGET")))) (if targ (or (configf:lookup config targ var) (configf:lookup config "default" var)) (configf:lookup config "default" var)))) ;;====================================================================== ;; R U N S ;;====================================================================== ;; set tests with state currstate and status currstatus to newstate and newstatus ;; use currstate = #f and or currstatus = #f to apply to any state or status respectively ;; WARNING: SQL injection risk. NB// See new but not yet used "faster" version below ;; ;; AND NOT (item_path='' AND testname in (SELECT DISTINCT testname FROM tests WHERE testname=? AND item_path != ''));"))) ;; (debug:print 0 *default-log-port* "QRY: " qry) ;; (db:delay-if-busy) |
︙ | ︙ | |||
1014 1015 1016 1017 1018 1019 1020 1021 1022 | )))))) (mutex-unlock! *db-transaction-mutex*) (if (and test-id state status (equal? status "AUTO")) (db:test-data-rollup dbstruct run-id test-id status)) (if new-state-eh ;; moved from db:test-set-state-status (mt:process-triggers dbstruct run-id test-id new-state-eh new-status-eh)) tr-res))))) | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 | )))))) (mutex-unlock! *db-transaction-mutex*) (if (and test-id state status (equal? status "AUTO")) (db:test-data-rollup dbstruct run-id test-id status)) (if new-state-eh ;; moved from db:test-set-state-status (mt:process-triggers dbstruct run-id test-id new-state-eh new-status-eh)) tr-res))))) (define (mt:process-triggers dbstruct run-id test-id newstate newstatus) (if test-id (let* ((test-dat (db:get-test-info-by-id dbstruct run-id test-id))) (if test-dat (let* ((test-rundir (db:test-get-rundir test-dat)) ;; ) ;; ) (test-name (db:test-get-testname test-dat)) (item-path (db:test-get-item-path test-dat)) (duration (db:test-get-run_duration test-dat)) (comment (db:test-get-comment test-dat)) (event-time (db:test-get-event_time test-dat)) (tconfig #f) (state (if newstate newstate (db:test-get-state test-dat))) (status (if newstatus newstatus (db:test-get-status test-dat))) (target (getenv "MT_TARGET")) (runname (getenv "MT_RUNNAME"))) ;; (mutex-lock! *triggers-mutex*) ;;;;;; (handle-exceptions ;;;;;; exn ;;;;;; (begin ;;;;;; (debug:print-error 0 *default-log-port* " Exception in mt:process-triggers for run-id="run-id" test-id="test-id" newstate="newstate" newstatus="newstatus ;;;;;; "\n error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn ;;;;;; "\n test-rundir="test-rundir ;;;;;; "\n test-name="test-name ;;;;;; "\n item-path="item-path ;;;;;; "\n state="state ;;;;;; "\n status="status ;;;;;; "\n") ;;;;;; (print-call-chain (current-error-port)) ;;;;;; (with-output-to-port *default-log-port* ;;;;;; (lambda () ;;;;;; (print (condition->list exn)))) ;;;;;; #f) (if (and test-name test-rundir) ;; #f means no dir set yet ;; (common:file-exists? test-rundir) ;; (directory? test-rundir)) (call-with-environment-variables (list (cons "MT_TEST_NAME" (or test-name "no such test")) (cons "MT_TEST_RUN_DIR" (or test-rundir "no test directory yet")) (cons "MT_ITEMPATH" (or item-path ""))) (lambda () (if (directory-exists? test-rundir) (push-directory test-rundir) (push-directory *toppath*)) (set! tconfig (mt:lazy-read-test-config test-name)) (for-each (lambda (trigger) (let* ((munged-trigger (string-translate trigger "/ " "--")) (logname (conc "last-trigger-" munged-trigger ".log"))) ;; first any triggers from the testconfig (let ((cmd (configf:lookup tconfig "triggers" trigger))) (if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "tconfig-" logname) test-name item-path event-time state status target runname))) ;; next any triggers from megatest.config (let ((cmd (configf:lookup *configdat* "triggers" trigger))) (if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "mtconfig-" logname) test-name item-path event-time state status target runname))))) (list (conc state "/" status) (conc state "/") (conc "/" status))) (pop-directory)) )) ;; ) ;; (mutex-unlock! *triggers-mutex*) ))))) ) |
Modified mt.scm from [126ce6cc42] to [722efc07f5].
︙ | ︙ | |||
72 73 74 75 76 77 78 | newtcfg)) (if (null? tal) (begin (debug:print-error 0 *default-log-port* "No readable testconfig found for " test-name) #f) (loop (car tal)(cdr tal)))))))))) | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 72 73 74 75 76 77 78 | newtcfg)) (if (null? tal) (begin (debug:print-error 0 *default-log-port* "No readable testconfig found for " test-name) #f) (loop (car tal)(cdr tal)))))))))) |
Modified rmtmod.scm from [d4fbb5087f] to [4f05580f62].
︙ | ︙ | |||
1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 | 'new2old '(dejunk) ))) (if (common:api-changed?) (common:set-last-run-version))) ) | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 | 'new2old '(dejunk) ))) (if (common:api-changed?) (common:set-last-run-version))) (define (mt:lazy-get-prereqs-not-met run-id waitons ref-item-path #!key (mode '(normal))(itemmaps #f) ) (let* ((key (list run-id waitons ref-item-path mode)) (res (hash-table-ref/default *pre-reqs-met-cache* key #f)) (useres (let ((last-time (if (vector? res) (vector-ref res 0) #f))) (if last-time (< (current-seconds)(+ last-time 5)) #f)))) (if useres (let ((result (vector-ref res 1))) (debug:print 4 *default-log-port* "Using lazy value res: " result) result) (let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmaps: itemmaps))) (hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres)) newres)))) ;;====================================================================== ;; T E S T S ;;====================================================================== (define (mt:get-tests-for-run run-id testpatt states status #!key (not-in #t) (sort-by 'event_time) (sort-order "ASC") (qryvals #f)(last-update #f)) (let loop ((testsdat (rmt:get-tests-for-run run-id testpatt states status 0 500 not-in sort-by sort-order qryvals last-update 'normal)) (res '()) (offset 0) (limit 500)) (let* ((full-list (append res testsdat)) (have-more (eq? (length testsdat) limit))) (if have-more (let ((new-offset (+ offset limit))) (debug:print-info 4 *default-log-port* "More than " limit " tests, have " (length full-list) " tests so far.") (loop (rmt:get-tests-for-run run-id testpatt states status new-offset limit not-in sort-by sort-order qryvals last-update 'normal) full-list new-offset limit)) full-list)))) ;; runs:get-runs-by-patt ;; get runs by list of criteria ;; register a test run with the db ;; ;; Use: (db-get-value-by-header (db:get-header runinfo)(db:get-rows runinfo)) ;; to extract info from the structure returned ;; (define (mt:get-runs-by-patt keys runnamepatt targpatt) (let loop ((runsdat (rmt:get-runs-by-patt keys runnamepatt targpatt 0 500 #f 0)) (res '()) (offset 0) (limit 500)) ;; (print "runsdat: " runsdat) (let* ((header (vector-ref runsdat 0)) (runslst (vector-ref runsdat 1)) (full-list (append res runslst)) (have-more (eq? (length runslst) limit))) ;; (debug:print 0 *default-log-port* "header: " header " runslst: " runslst " have-more: " have-more) (if have-more (let ((new-offset (+ offset limit)) (next-batch (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit #f 0))) (debug:print-info 4 *default-log-port* "More than " limit " runs, have " (length full-list) " runs so far.") (debug:print-info 0 *default-log-port* "next-batch: " next-batch) (loop next-batch full-list new-offset limit)) (vector header full-list))))) ;;;====================================================================== ;; S T A T E A N D S T A T U S F O R T E S T S ;;====================================================================== ;; speed up for common cases with a little logic (define (mt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment) (if (not (and run-id test-id)) (begin (debug:print-error 0 *default-log-port* "bad data handed to mt:test-set-state-status-by-id, run-id=" run-id ", test-id=" test-id ", newstate=" newstate) (print-call-chain (current-error-port)) #f) (begin ;; cond ;; ((and newstate newstatus newcomment) ;; (rmt:general-call 'state-status-msg run-id newstate newstatus newcomment test-id)) ;; ((and newstate newstatus) ;; (rmt:general-call 'state-status run-id newstate newstatus test-id)) ;; (else ;; (if newstate (rmt:general-call 'set-test-state run-id newstate test-id)) ;; (if newstatus (rmt:general-call 'set-test-status run-id newstatus test-id)) ;; (if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id)))) (rmt:set-state-status-and-roll-up-items run-id test-id #f newstate newstatus newcomment) ;; (mt:process-triggers run-id test-id newstate newstatus) #t))) (define (mt:test-set-state-status-by-testname-unless-completed run-id test-name item-path new-state new-status new-comment) (let ((test-id (rmt:get-test-id run-id test-name item-path))) (mt:test-set-state-status-by-id-unless-completed run-id test-id new-state new-status new-comment))) (define (mt:test-set-state-status-by-id-unless-completed run-id test-id newstate newstatus newcomment) (let* ((test-vec (rmt:get-testinfo-state-status run-id test-id)) (state (vector-ref test-vec 3))) (if (equal? state "COMPLETED") #t (rmt:set-state-status-and-roll-up-items run-id test-id #f newstate newstatus newcomment)))) (define (mt:test-set-state-status-by-testname run-id test-name item-path new-state new-status new-comment) ;(let ((test-id (rmt:get-test-id run-id test-name item-path))) (rmt:set-state-status-and-roll-up-items run-id test-name item-path new-state new-status new-comment) ;; (mt:process-triggers run-id test-id new-state new-status) #t);) ;;(mt:test-set-state-status-by-id run-id test-id new-state new-status new-comment))) ) |
Modified runconfig.scm from [e745c7478e] to [94a5dd2abf].
︙ | ︙ | |||
163 164 165 166 167 168 169 | ;; first break all parts into individual target patterns (if (string-index hed " ") ;; this is a multi-target target (let ((newres (append (string-split hed " ") res))) (runconfig:expand-target newres)) (if (string-index hed ",") ;; this is a multi-target where one or more parts are comma separated |# | > | 163 164 165 166 167 168 169 170 | ;; first break all parts into individual target patterns (if (string-index hed " ") ;; this is a multi-target target (let ((newres (append (string-split hed " ") res))) (runconfig:expand-target newres)) (if (string-index hed ",") ;; this is a multi-target where one or more parts are comma separated |# |
Modified utils/plot-uses.scm from [a8d79f928b] to [39edbe170d].
︙ | ︙ | |||
57 58 59 60 61 62 63 64 65 66 67 68 69 70 | (member modname ignores) (member unitname ignores))) (print " \""unitname"\" -> \""modname"\";")) (print-err "ERROR: bad declare line \""inl"\"")) (loop modname)))) (else (loop modname))))))))) (define (main) (match (command-line-arguments) (("todot" ignoreunits . files) (let* ((ignores (string-split ignoreunits ","))) (print-err "Making graph for files: " (string-intersperse files ", ")) (print "digraph uses_unit {") | > > > > > > > > | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 | (member modname ignores) (member unitname ignores))) (print " \""unitname"\" -> \""modname"\";")) (print-err "ERROR: bad declare line \""inl"\"")) (loop modname)))) (else (loop modname))))))))) ;; ./utils/plot-uses todot portlogger,stml2,debugprint,mtargs ;; apimod.scm commonmod.scm configfmod.scm dbmod.scm megatestmod.scm ;; mtmod.scm processmod.scm rmtmod.scm servermod.scm ;; tcp-transportmod.scm > uses.dot ;; dot uses.dot -Tpdf -o uses.pdf (define (main) (match (command-line-arguments) (("todot" ignoreunits . files) (let* ((ignores (string-split ignoreunits ","))) (print-err "Making graph for files: " (string-intersperse files ", ")) (print "digraph uses_unit {") |
︙ | ︙ |