Changes In Branch v1.70-refactor01 Through [9dfe7d1083] Excluding Merge-Ins
This is equivalent to a diff from e6296edad4 to 9dfe7d1083
2019-12-12
| ||
14:32 | Cherrypicked removal of telemetric stuff (removing all complexities for now). check-in: 400ad607f4 user: mrwellan tags: v1.70-defunct-try | |
2019-12-11
| ||
22:14 | shuffling stuff around. Currently fails to run: (rmt:get-runs-by-patt '(contour_name release iteration testsuite_mode) #f all/v1.70/1.7001/dev 0 500 #f 0 asc) but does run (db:get-runs-by-patt *db* '(contour_name release iteration testsuite_mode) % all/v1.70/1.7001/dev 0 500 #f 0 asc) check-in: ba4a9f34c8 user: matt tags: v1.70-refactor01, v1.70-defunct-try | |
21:57 | shuffling stuff around. Currently fails to run: (rmt:get-runs-by-patt '(contour_name release iteration testsuite_mode) #f all/v1.70/1.7001/dev 0 500 #f 0 asc) check-in: 9dfe7d1083 user: matt tags: v1.70-refactor01, v1.70-defunct-try | |
20:20 | Moved couple procs from runs-inc into runsmod. check-in: e6296edad4 user: matt tags: v1.70-defunct-try | |
16:57 | Preserve vars and reset them when doing items manipulations.: check-in: e84ced5564 user: mrwellan tags: v1.70-defunct-try | |
Modified Makefile from [6eaa99694a] to [3b8892abb7].
︙ | ︙ | |||
195 196 197 198 199 200 201 202 203 204 205 206 207 208 | # for the modularized stuff mofiles/commonmod.o : megatest-fossil-hash.scm mofiles/dbmod.o : mofiles/commonmod.o mofiles/keysmod.o mofiles/tasksmod.o mofiles/odsmod.o mofiles/commonmod.o : mofiles/processmod.o mofiles/rmtmod.o : mofiles/dbmod.o mofiles/commonmod.o mofiles/apimod.o mofiles/apimod.o : mofiles/dbmod.o # Removed from megamod.o dep: mofiles/ftail.o mofiles/megamod.o : \ mofiles/rmtmod.o \ mofiles/commonmod.o \ mofiles/apimod.o \ mofiles/archivemod.o \ mofiles/clientmod.o \ | > > | 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 | # for the modularized stuff mofiles/commonmod.o : megatest-fossil-hash.scm mofiles/dbmod.o : mofiles/commonmod.o mofiles/keysmod.o mofiles/tasksmod.o mofiles/odsmod.o mofiles/commonmod.o : mofiles/processmod.o mofiles/rmtmod.o : mofiles/dbmod.o mofiles/commonmod.o mofiles/apimod.o mofiles/apimod.o : mofiles/dbmod.o mofiles/runsmod.o : mofiles/testsmod.o # Removed from megamod.o dep: mofiles/ftail.o mofiles/megamod.o : \ mofiles/rmtmod.o \ mofiles/commonmod.o \ mofiles/apimod.o \ mofiles/archivemod.o \ mofiles/clientmod.o \ |
︙ | ︙ |
Modified common-inc.scm from [b0ac284799] to [bede31db09].
︙ | ︙ | |||
73 74 75 76 77 78 79 | (else (car argv)))) (fullpath (realpath this-script))) fullpath)) (define *common:this-exe-fullpath* (common:get-this-exe-fullpath)) (define *common:this-exe-dir* (pathname-directory *common:this-exe-fullpath*)) (define *common:this-exe-name* (pathname-strip-directory *common:this-exe-fullpath*)) | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 | (else (car argv)))) (fullpath (realpath this-script))) fullpath)) (define *common:this-exe-fullpath* (common:get-this-exe-fullpath)) (define *common:this-exe-dir* (pathname-directory *common:this-exe-fullpath*)) (define *common:this-exe-name* (pathname-strip-directory *common:this-exe-fullpath*)) ;; Move me elsewhere ... ;; RADT => Why do we meed the version check here, this is called only if version misma ;; (define (common:cleanup-db dbstruct #!key (full #f)) (apply db:multi-db-sync dbstruct 'schema |
︙ | ︙ | |||
452 453 454 455 456 457 458 | (mutex-unlock! *db-access-mutex*)))) val)) ;;====================================================================== ;; U S E F U L S T U F F ;;====================================================================== | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 349 350 351 352 353 354 355 356 357 358 359 360 361 362 | (mutex-unlock! *db-access-mutex*)))) val)) ;;====================================================================== ;; U S E F U L S T U F F ;;====================================================================== ;; 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)) (if (common:file-exists? fname) (if (> (- (current-seconds)(file-modification-time fname)) expire-time) |
︙ | ︙ | |||
545 546 547 548 549 550 551 | ;;====================================================================== ;; D E B U G G I N G S T U F F ;;====================================================================== ;; (define *verbosity* 1) ;; (define *logging* #f) | | | < > > | < | | | | < < < < > > | > | < < > | | < < < < | < | | | < < < | 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 | ;;====================================================================== ;; D E B U G G I N G S T U F F ;;====================================================================== ;; (define *verbosity* 1) ;; (define *logging* #f) (define (common:set-last-run-version) (rmt:set-var "MEGATEST_VERSION" (common:version-signature))) ;; postive number if megatest version > db version ;; negative number if megatest version < db version (define (common:version-db-delta) (- megatest-version (common:get-last-run-version-number))) (define (common:version-changed?) (not (equal? (common:get-last-run-version) (common:version-signature)))) ;; from metadat lookup MEGATEST_VERSION ;; (define (common:get-last-run-version) ;; RADT => How does this work in send-receive function??; assume it is the value saved in some DB (rmt:get-var "MEGATEST_VERSION")) (define (common:get-last-run-version-number) (string->number (substring (common:get-last-run-version) 0 6))) (define (common:api-changed?) (not (equal? (substring (->string megatest-version) 0 4) (substring (conc (common:get-last-run-version)) 0 4)))) ;;====================================================================== ;; E X I T H A N D L I N G ;;====================================================================== (define (common:run-sync?) (and (common:on-homehost?) |
︙ | ︙ | |||
761 762 763 764 765 766 767 | (target-patt (args:get-arg "-target"))) (if target-patt (filter (lambda (x) (patt-list-match x target-patt)) targs) targs))) | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 603 604 605 606 607 608 609 610 611 612 613 614 615 616 | (target-patt (args:get-arg "-target"))) (if target-patt (filter (lambda (x) (patt-list-match x target-patt)) targs) targs))) ;; logic for getting homehost. Returns (host . at-home) ;; IF *toppath* is not set, wait up to five seconds trying every two seconds ;; (this is to accomodate the watchdog) ;; (define (common:get-homehost #!key (trynum 5)) ;; called often especially at start up. use mutex to eliminate collisions (mutex-lock! *homehost-mutex*) |
︙ | ︙ |
Modified commonmod.scm from [1a18aaecd2] to [d35f1518fe].
︙ | ︙ | |||
29 30 31 32 33 34 35 | (import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-1 files format srfi-13 matchable srfi-69 ports regex-case regex hostinfo srfi-4 pkts (prefix dbi dbi:) stack md5 | | | < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 29 30 31 32 33 34 35 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 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 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 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 | (import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-1 files format srfi-13 matchable srfi-69 ports regex-case regex hostinfo srfi-4 pkts (prefix dbi dbi:) stack md5 message-digest (prefix mtconfigf configf:) stml2 (prefix margs args:) z3 (prefix base64 base64:)) (include "common_records.scm") (include "megatest-fossil-hash.scm") (include "megatest-version.scm") ;; no need to export this (define *verbosity-cache* (make-hash-table)) (define *verbosity* 0) ;; GLOBALS ;; CONTEXTS #;(defstruct cxt (taskdb #f) (cmutex (make-mutex))) ;; (define *contexts* (make-hash-table)) ;; (define *context-mutex* (make-mutex)) ;; ;; safe method for accessing a context given a toppath ;; ;; ;; (define (common:with-cxt toppath proc) ;; (mutex-lock! *context-mutex*) ;; (let ((cxt (hash-table-ref/default *contexts* toppath #f))) ;; (if (not cxt) ;; (set! cxt (let ((x (make-cxt)))(hash-table-set! *contexts* toppath x) x))) ;; (let ((cxt-mutex (cxt-mutex cxt))) ;; (mutex-unlock! *context-mutex*) ;; (mutex-lock! cxt-mutex) ;; (let ((res (proc cxt))) ;; (mutex-unlock! cxt-mutex) ;; res)))) ;; A hash table that can be accessed by #{scheme ...} calls in ;; config files. Allows communicating between confgs ;; (define *user-hash-data* (make-hash-table)) (define *db-keys* #f) (define *pkts-info* (make-hash-table)) ;; store stuff like the last parent here (define *configinfo* #f) ;; raw results from setup, includes toppath and table from megatest.config (define *runconfigdat* #f) ;; run configs data (define *configdat* #f) ;; megatest.config data (define *configstatus* #f) ;; status of data; 'fulldata : all processing done, #f : no data yet, 'partialdata : partial read done (define *toppath* #f) (define *already-seen-runconfig-info* #f) (define *test-meta-updated* (make-hash-table)) (define *globalexitstatus* 0) ;; attempt to work around possible thread issues (define *passnum* 0) ;; when running track calls to run-tests or similar ;; (define *alt-log-file* #f) ;; used by -log (define *common:denoise* (make-hash-table)) ;; for low noise printing (define *default-log-port* (current-error-port)) (define *default-area-tag* "local") ;; DATABASE (define *dbstruct-db* #f) ;; used to cache the dbstruct in db:setup. Goal is to remove this. ;; db access (define *db-last-access* (current-seconds)) ;; last db access, used in server (define *db-write-access* #t) ;; db sync (define *db-last-sync* 0) ;; last time the sync to megatest.db happened (define *db-sync-in-progress* #f) ;; if there is a sync in progress do not try to start another (define *db-multi-sync-mutex* (make-mutex)) ;; protect access to *db-sync-in-progress*, *db-last-sync* ;; task db (define *task-db* #f) ;; (vector db path-to-db) (define *db-access-allowed* #t) ;; flag to allow access (define *db-access-mutex* (make-mutex)) (define *db-transaction-mutex* (make-mutex)) (define *db-cache-path* #f) (define *db-with-db-mutex* (make-mutex)) (define *db-api-call-time* (make-hash-table)) ;; hash of command => (list of times) ;; no sync db (define *no-sync-db* #f) ;; SERVER (define *my-client-signature* #f) (define *transport-type* 'http) ;; override with [server] transport http|rpc|nmsg (define *runremote* #f) ;; if set up for server communication this will hold <host port> ;; (define *max-cache-size* 0) (define *logged-in-clients* (make-hash-table)) (define *server-id* #f) (define *server-info* #f) ;; good candidate for easily convert to non-global (define *time-to-exit* #f) (define *server-run* #t) (define *run-id* #f) (define *server-kind-run* (make-hash-table)) (define *home-host* #f) ;; (define *total-non-write-delay* 0) (define *heartbeat-mutex* (make-mutex)) (define *api-process-request-count* 0) (define *max-api-process-requests* 0) (define *server-overloaded* #f) ;; client (define *rmt-mutex* (make-mutex)) ;; remote access calls mutex ;; RPC transport (define *rpc:listener* #f) ;; KEY info (define *target* (make-hash-table)) ;; cache the target here; target is keyval1/keyval2/.../keyvalN (define *keys* (make-hash-table)) ;; cache the keys here (define *keyvals* (make-hash-table)) (define *toptest-paths* (make-hash-table)) ;; cache toptest path settings here (define *test-paths* (make-hash-table)) ;; cache test-id to test run paths here (define *test-ids* (make-hash-table)) ;; cache run-id, testname, and item-path => test-id (define *test-info* (make-hash-table)) ;; cache the test info records, update the state, status, run_duration etc. from testdat.db (define *run-info-cache* (make-hash-table)) ;; run info is stable, no need to reget (define *launch-setup-mutex* (make-mutex)) ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set (define *homehost-mutex* (make-mutex)) ;; Miscellaneous (define *triggers-mutex* (make-mutex)) ;; block overlapping processing of triggers ;; this was cached based on results from profiling but it turned out the profiling ;; somehow went wrong - perhaps too many processes writing to it. Leaving the caching ;; in for now but can probably take it out later. ;; (define (debug:calc-verbosity vstr verbose quiet) ;; verbose and quiet are #f or enabled (or (hash-table-ref/default *verbosity-cache* vstr #f) (let ((res (cond |
︙ | ︙ | |||
136 137 138 139 140 141 142 143 144 145 146 147 148 149 | (lambda () ;; (if *logging* ;; (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params)))) ;; (exec-fn 'db:log-event res)) ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res) (apply print "INFO: (" n ") " params) ;; res) )))) ;; ) ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== ;; BBnote: *common:std-states* - dashboard filter control and test control state buttons defined here; used in set-fields-panel and dboard:make-controls | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 | (lambda () ;; (if *logging* ;; (let ((res (format#format #f "INFO: (~a) ~a" n (apply conc params)))) ;; (exec-fn 'db:log-event res)) ;; (apply print "pid:" (current-process-id) " " "INFO: (" n ") " params) ;; res) (apply print "INFO: (" n ") " params) ;; res) )))) ;; ) ;; Lookup a value in runconfigs based on -reqtarg or -target ;; (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)))) (define (common:args-get-state) (or (args:get-arg "-state")(args:get-arg ":state"))) (define (common:args-get-status) (or (args:get-arg "-status")(args:get-arg ":status"))) (define (common:args-get-testpatt rconf) (let* (;; (tagexpr (args:get-arg "-tagexpr")) ;; (tags-testpatt (if tagexpr (string-join (runs:get-tests-matching-tags tagexpr) ",") #f)) (testpatt-key (or (args:get-arg "-modepatt") (args:get-arg "--modepatt") "TESTPATT")) (args-testpatt (or (args:get-arg "-testpatt") (args:get-arg "-runtests") "%")) (rtestpatt (if rconf (runconfigs-get rconf testpatt-key) #f))) (cond ((or (args:get-arg "--modepatt") (args:get-arg "-modepatt")) ;; modepatt is a forced setting, when set it MUST refer to an existing PATT in the runconfig (if rconf (let* ((patts-from-mode-patt (runconfigs-get rconf testpatt-key))) (debug:print-info 0 *default-log-port* "modepatt defined is: "testpatt-key" runconfigs values for " testpatt-key " " patts-from-mode-patt) patts-from-mode-patt) (begin (debug:print-info 0 *default-log-port* " modepatt defined is: "testpatt-key" runconfigs values for " testpatt-key) ;; " " patts-from-mode-patt) #f))) ;; We do NOT fall back to "%" ;; (tags-testpatt ;; (debug:print-info 0 *default-log-port* "-tagexpr "tagexpr" selects testpatt "tags-testpatt) ;; tags-testpatt) ((and (equal? args-testpatt "%") rtestpatt) (debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt) rtestpatt) (else (debug:print-info 0 *default-log-port* "using testpatt " args-testpatt " rtestpatt:" rtestpatt) args-testpatt)))) (define (common:get-linktree) (or (getenv "MT_LINKTREE") (if *configdat* (configf:lookup *configdat* "setup" "linktree") (if *toppath* (conc *toppath* "/lt") #f)))) (define (common:args-get-runname) (let ((res (or (args:get-arg "-runname") (args:get-arg ":runname") (getenv "MT_RUNNAME")))) ;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ... res)) (define (common:get-fields cfgdat) (let ((fields (hash-table-ref/default cfgdat "fields" '()))) (map car fields))) (define (common:args-get-target #!key (split #f)(exit-if-bad #f)) (let* ((keys (if (hash-table? *configdat*) (common:get-fields *configdat*) '())) (numkeys (length keys)) (target (or (args:get-arg "-reqtarg") (args:get-arg "-target") (getenv "MT_TARGET"))) (tlist (if target (string-split target "/" #t) '())) (valid (if target (or (null? keys) ;; probably don't know our keys yet (and (not (null? tlist)) (eq? numkeys (length tlist)) (null? (filter string-null? tlist)))) #f))) (if valid (if split tlist target) (if target (begin (debug:print-error 0 *default-log-port* "Invalid target, spaces or blanks not allowed \"" target "\", target should be: " (string-intersperse keys "/") ", have " tlist " for elements") (if exit-if-bad (exit 1)) #f) #f)))) ;; looking only (at least for now) at the MT_ variables craft the full testname ;; (define (common:get-full-test-name) (if (getenv "MT_TEST_NAME") (if (and (getenv "MT_ITEMPATH") (not (equal? (getenv "MT_ITEMPATH") ""))) (getenv "MT_TEST_NAME") (conc (getenv "MT_TEST_NAME") "/" (getenv "MT_ITEMPATH"))) #f)) ;;====================================================================== ;; S T A T E S A N D S T A T U S E S ;;====================================================================== ;; BBnote: *common:std-states* - dashboard filter control and test control state buttons defined here; used in set-fields-panel and dboard:make-controls |
︙ | ︙ | |||
593 594 595 596 597 598 599 | (define (get-file-descriptor-count #!key (pid (current-process-id ))) (list (length (glob (conc "/proc/" pid "/fd/*"))) (length (filter identity (map socket? (glob (conc "/proc/" pid "/fd/*"))))) ) ) | | | | | < | < < < < | < < < < < | < < < < < < < | < < < < | | < < < < < < < | > > | < < < < | | < < | < < > | < < < | < < < < < < < < < | < < < < < < < < < < < < < < < < < < < | | < < | < < < < < < < < | < < < < < | | | | | | | | | | | | < < < < < < < < < < < < < < < < < | | | < < < < < < < < < < < < < < < < < < < | < | | | < | | > | < < < < | < < < < < < | < < < < < < | < < | < < < < < < < < < < < < | | < < < > | | | | | < < < | > | < < < < | < < < < < < < < < < < < < < < < < < < < > | | < < < < < < < < < < | < | | > | < < < > | < < < < < < < < < < < < < < > | | < < < < < < < < < < < < < < < | < < | < | < < < < < < < | > | < > | < > > | < | < < < < < | > > | < < < < < | < < < < < < < < < < < < | < < < < < < | | < < < < | < < < < < > | < < < < < < | < < < < < > | < < > | | < < < | < > | | < | < | < | < < > | > | < < < < < < < < < < < < < < < < < < < < | > | | | | | | | < < < < < < | < < < < < < < < < < < < < < < < < < < < < < | | | < | > | | | | | < < < < < < | < < < < | < < < < < < < < < | < < < < | | | < < < < < < | < < < | < < < < < < | < < < < < | < < < < < < | | | < | > | | | < < < < < | < < < < | < < < | < < < < < < < < < < < | | | | 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 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 | (define (get-file-descriptor-count #!key (pid (current-process-id ))) (list (length (glob (conc "/proc/" pid "/fd/*"))) (length (filter identity (map socket? (glob (conc "/proc/" pid "/fd/*"))))) ) ) (define *common:logpro-exit-code->status-sym-alist* '( ( 0 . pass ) ( 1 . fail ) ( 2 . warn ) ( 3 . check ) ( 4 . waived ) ( 5 . abort ) ( 6 . skip ))) (define (common:logpro-exit-code->status-sym exit-code) (or (alist-ref exit-code *common:logpro-exit-code->status-sym-alist*) 'fail)) (define (common:worse-status-sym ss1 ss2) (let loop ((status-syms-remaining '(abort fail check skip warn waived pass))) (cond ((null? status-syms-remaining) 'fail) ((eq? (car status-syms-remaining) ss1) ss1) ((eq? (car status-syms-remaining) ss2) ss2) (else (loop (cdr status-syms-remaining)))))) (define (common:steps-can-proceed-given-status-sym status-sym) (if (member status-sym '(warn waived pass)) #t #f)) (define (status-sym->string status-sym) (case status-sym ((pass) "PASS") ((fail) "FAIL") ((warn) "WARN") ((check) "CHECK") ((waived) "WAIVED") ((abort) "ABORT") ((skip) "SKIP") (else "FAIL"))) (define (common:logpro-exit-code->test-status exit-code) (status-sym->string (common:logpro-exit-code->status-sym exit-code))) (define (common:clear-caches) (set! *target* (make-hash-table)) (set! *keys* (make-hash-table)) (set! *keyvals* (make-hash-table)) (set! *toptest-paths* (make-hash-table)) (set! *test-paths* (make-hash-table)) (set! *test-ids* (make-hash-table)) (set! *test-info* (make-hash-table)) (set! *run-info-cache* (make-hash-table)) (set! *env-vars-by-run-id* (make-hash-table)) (set! *test-id-cache* (make-hash-table))) ;; Generic string database (define sdb:qry #f) ;; (make-sdb:qry)) ;; 'init #f) ;; Generic path database (define *fdb* #f) (define *last-launch* (current-seconds)) ;; use for throttling the launch rate. Would be better to use the db and last time of a test in LAUNCHED state. ;;====================================================================== ;; V E R S I O N ;;====================================================================== (define (common:get-full-version) (conc megatest-version "-" megatest-fossil-hash)) (define (common:version-signature) (conc megatest-version "-" (substring megatest-fossil-hash 0 4))) (define (common:get-sync-lock-filepath) (let* ((tmp-area (common:get-db-tmp-area)) (lockfile (conc tmp-area "/megatest.db.sync-lock"))) lockfile)) ;;====================================================================== ;; U S E F U L S T U F F ;;====================================================================== ;; convert things to an alist or assoc list, #f gets converted to "" ;; (define (common:to-alist dat) (cond ((list? dat) (map common:to-alist dat)) ((vector? dat) (map common:to-alist (vector->list dat))) ((pair? dat) (cons (common:to-alist (car dat)) (common:to-alist (cdr dat)))) ((hash-table? dat) (map common:to-alist (hash-table->alist dat))) (else (if dat dat "")))) (define (common:alist-ref/default key alist default) (or (alist-ref key alist) default)) (define (common:low-noise-print waitval . keys) (let* ((key (string-intersperse (map conc keys) "-" )) (lasttime (hash-table-ref/default *common:denoise* key 0)) (currtime (current-seconds))) (if (> (- currtime lasttime) waitval) (begin (hash-table-set! *common:denoise* key currtime) #t) #f))) (define (common:get-megatest-exe) (or (getenv "MT_MEGATEST") "megatest")) (define (common:read-encoded-string instr) (handle-exceptions exn (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* "received bad encoded string \"" instr "\", message: " ((condition-property-accessor 'exn 'message) exn)) (print-call-chain (current-error-port)) #f) (read (open-input-string (base64:base64-decode instr)))) (read (open-input-string (z3:decode-buffer (base64:base64-decode instr)))))) ;;====================================================================== ;; Configf extentions ;;====================================================================== (define (get-with-default val default) (let ((val (args:get-arg val))) (if val val default))) (define (assoc/default key lst . default) (let ((res (assoc key lst))) (if res (cadr res)(if (null? default) #f (car default))))) (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") (if (string? *toppath* ) (pathname-file *toppath*) #f))) ;; (pathname-file (current-directory))))) (define common:get-area-name common:get-testsuite-name) (define (common:get-db-tmp-area . junk) (if *db-cache-path* *db-cache-path* (if *toppath* ;; common:get-create-writeable-dir (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* "Couldn't create path to " *db-cache-path*) (exit 1)) (let ((dbpath (common:get-create-writeable-dir (list (conc "/tmp/" (current-user-name) "/megatest_localdb/" (common:get-testsuite-name) "/" (string-translate *toppath* "/" ".")))))) ;; #t)))) (set! *db-cache-path* dbpath) dbpath)) #f))) ;; pulled from common_records.scm ;; globals - modules that include this need these here (define *logging* #f) (define *functions* (make-hash-table)) ;; symbol => fn ### TEMPORARY!!! ;; (define *toppath* #f) |
︙ | ︙ |
Modified dashboard.scm from [d824c79472] to [e29ff98288].
︙ | ︙ | |||
24 25 26 27 28 29 30 | (import (prefix iup iup:)) (use canvas-draw) (import canvas-draw-iup) (use ducttape-lib) (use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors srfi-18 | | > | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | (import (prefix iup iup:)) (use canvas-draw) (import canvas-draw-iup) (use ducttape-lib) (use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors srfi-18 (prefix mtconfigf configf:) (prefix margs args:)) (import (prefix sqlite3 sqlite3:)) ;; (declare (uses common)) ;; (declare (uses margs)) ;; (declare (uses keys)) ;; (declare (uses items)) ;; (declare (uses db)) |
︙ | ︙ | |||
57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 | (import commonmod) (declare (uses rmtmod)) (import rmtmod) (declare (uses runsmod)) (import runsmod) (declare (uses dbmod)) (import dbmod) (declare (uses dcommonmod)) (import dcommonmod) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") (include "task_records.scm") ;; (include "megatest-fossil-hash.scm") ;; comes from megamod (include "vg_records.scm") ;; invoke the imports (declare (uses commonmod.import)) (declare (uses rmtmod.import)) (declare (uses runsmod.import)) (declare (uses megamod.import)) (declare (uses dcommonmod.import)) (configf:set-debug-printers debug:print debug:print-info debug:print-error *default-log-port*) (configf:add-eval-string "(import megamod)(import commonmod)") | > > > | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 | (import commonmod) (declare (uses rmtmod)) (import rmtmod) (declare (uses runsmod)) (import runsmod) (declare (uses dbmod)) (import dbmod) (declare (uses testsmod)) (import testsmod) (declare (uses dcommonmod)) (import dcommonmod) (include "common_records.scm") (include "db_records.scm") (include "run_records.scm") (include "task_records.scm") ;; (include "megatest-fossil-hash.scm") ;; comes from megamod (include "vg_records.scm") ;; invoke the imports (declare (uses commonmod.import)) (declare (uses testsmod.import)) (declare (uses rmtmod.import)) (declare (uses runsmod.import)) (declare (uses megamod.import)) (declare (uses dcommonmod.import)) (configf:set-debug-printers debug:print debug:print-info debug:print-error *default-log-port*) (configf:add-eval-string "(import megamod)(import commonmod)") |
︙ | ︙ |
Modified db-inc.scm from [1e3b4cba33] to [331eedb743].
︙ | ︙ | |||
2085 2086 2087 2088 2089 2090 2091 | (sqlite3:for-each-row (lambda (val) (set! res val)) db (conc "SELECT " key " FROM runs WHERE id=?;") run-id) res)))) | < < < < < < < < < < < < < < < < < < < < < | 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 | (sqlite3:for-each-row (lambda (val) (set! res val)) db (conc "SELECT " key " FROM runs WHERE id=?;") run-id) res)))) ;; register a test run with the db, this accesses the main.db and does NOT ;; use server api ;; (define (db:register-run dbstruct keyvals runname state status user contour-in) (let* ((keys (map car keyvals)) (keystr (keys->keystr keys)) |
︙ | ︙ | |||
4323 4324 4325 4326 4327 4328 4329 | db "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta;") res)))) ;;====================================================================== ;; M I S C M A N A G E M E N T I T E M S ;;====================================================================== | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 | db "SELECT id,testname,author,owner,description,reviewed,iterated,avg_runtime,avg_disk,tags,jobgroup FROM test_meta;") res)))) ;;====================================================================== ;; M I S C M A N A G E M E N T I T E M S ;;====================================================================== ;; the new prereqs calculation, looks also at itempath if specified ;; all prereqs must be met ;; if prereq test with itempath='' is COMPLETED and PASS, WARN, CHECK, or WAIVED then prereq is met ;; if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met |
︙ | ︙ |
Modified dcommonmod.scm from [5fdbbc15ad] to [80c862d803].
︙ | ︙ | |||
16 17 18 19 20 21 22 23 24 25 26 27 28 29 | ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit dcommonmod)) (declare (uses commonmod)) (declare (uses megamod)) (module dcommonmod * (import scheme chicken data-structures extras) (import (prefix sqlite3 sqlite3:) | > | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit dcommonmod)) (declare (uses commonmod)) (declare (uses testsmod)) (declare (uses megamod)) (module dcommonmod * (import scheme chicken data-structures extras) (import (prefix sqlite3 sqlite3:) |
︙ | ︙ | |||
78 79 80 81 82 83 84 85 86 87 88 89 90 91 | uri-common z3 ) (use (prefix mtconfigf configf:)) (import commonmod) (import megamod) (import canvas-draw) (import canvas-draw-iup) (use (prefix iup iup:)) (define *tim* (iup:timer)) | > | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 | uri-common z3 ) (use (prefix mtconfigf configf:)) (import commonmod) (import testsmod) (import megamod) (import canvas-draw) (import canvas-draw-iup) (use (prefix iup iup:)) (define *tim* (iup:timer)) |
︙ | ︙ |
Modified keys-inc.scm from [b354a0320e] to [7ccee887c9].
︙ | ︙ | |||
13 14 15 16 17 18 19 | ;; 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 <http://www.gnu.org/licenses/>. ;; | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 13 14 15 16 17 18 19 | ;; 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 <http://www.gnu.org/licenses/>. ;; |
Modified megamod.scm from [a6b1e51810] to [72c329a55f].
︙ | ︙ | |||
37 38 39 40 41 42 43 | ;; (declare (uses odsmod)) ;; (declare (uses processmod)) ;; (declare (uses runconfigmod)) (declare (uses runsmod)) ;; (declare (uses servermod)) ;; (declare (uses subrunmod)) ;; (declare (uses tasksmod)) | | | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 | ;; (declare (uses odsmod)) ;; (declare (uses processmod)) ;; (declare (uses runconfigmod)) (declare (uses runsmod)) ;; (declare (uses servermod)) ;; (declare (uses subrunmod)) ;; (declare (uses tasksmod)) (declare (uses testsmod)) ;; (declare (uses vgmod)) (module megamod * (import scheme chicken data-structures extras) (use |
︙ | ︙ | |||
120 121 122 123 124 125 126 | ;; (import processmod) (import rmtmod) ;; (import runconfigmod) (import runsmod) ;; (import servermod) ;; (import subrunmod) ;; (import tasksmod) | | | 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 | ;; (import processmod) (import rmtmod) ;; (import runconfigmod) (import runsmod) ;; (import servermod) ;; (import subrunmod) ;; (import tasksmod) (import testsmod) ;; (import vgmod) (use (prefix ulex ulex:)) (include "common_records.scm") (include "db_records.scm") (include "key_records.scm") |
︙ | ︙ | |||
166 167 168 169 170 171 172 | (include "archive-inc.scm") (include "client-inc.scm") (include "common-inc.scm") ;; L5 (include "db-inc.scm") ;; L4 (include "env-inc.scm") (include "http-transport-inc.scm") (include "items-inc.scm") | | | 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 | (include "archive-inc.scm") (include "client-inc.scm") (include "common-inc.scm") ;; L5 (include "db-inc.scm") ;; L4 (include "env-inc.scm") (include "http-transport-inc.scm") (include "items-inc.scm") ;; (include "keys-inc.scm") (include "launch-inc.scm") ;; L1 (include "margs-inc.scm") (include "mt-inc.scm") (include "ods-inc.scm") ;; L1 (include "pgdb-inc.scm") (include "portlogger-inc.scm") (include "process-inc.scm") ;; L6 |
︙ | ︙ |
Modified megatest.scm from [607ccce4b1] to [2845293d3c].
︙ | ︙ | |||
21 22 23 24 25 26 27 | ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:) readline apropos json http-client directory-utils typed-records http-client srfi-18 extras format | | > | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) (use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:) readline apropos json http-client directory-utils typed-records http-client srfi-18 extras format (prefix mtconfigf configf:) (prefix margs args:)) ;; Added for csv stuff - will be removed ;; (use sparse-vectors) (require-library mutils) |
︙ | ︙ | |||
52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 | (import commonmod) (declare (uses rmtmod)) (import rmtmod) (declare (uses dbmod)) (import dbmod) (declare (uses runsmod)) (import runsmod) (declare (uses megamod)) (import megamod) ;; invoke the imports (declare (uses commonmod.import)) (declare (uses rmtmod.import)) (declare (uses runsmod.import)) (declare (uses megamod.import)) (configf:set-debug-printers debug:print debug:print-info debug:print-error *default-log-port*) ;; (declare (uses tdb)) | > > > | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 | (import commonmod) (declare (uses rmtmod)) (import rmtmod) (declare (uses dbmod)) (import dbmod) (declare (uses runsmod)) (import runsmod) (declare (uses testsmod)) (import testsmod) (declare (uses megamod)) (import megamod) ;; invoke the imports (declare (uses commonmod.import)) (declare (uses testsmod.import)) (declare (uses rmtmod.import)) (declare (uses runsmod.import)) (declare (uses megamod.import)) (configf:set-debug-printers debug:print debug:print-info debug:print-error *default-log-port*) ;; (declare (uses tdb)) |
︙ | ︙ |
Modified runs-inc.scm from [cb209f098e] to [db274d97cc].
︙ | ︙ | |||
268 269 270 271 272 273 274 | (print-call-chain *default-log-port*) (debug:print 0 *default-log-port* "Message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 0 *default-log-port* "ERROR: failed to run post-hook " run-post-hook ", check the log " log-file)) (debug:print-info 0 *default-log-port* "running run-post-hook: \"" run-post-hook "\", log is " actual-logf) (system (conc run-post-hook " >> " actual-logf " 2>&1")) (debug:print-info 0 *default-log-port* "post-hook \"" run-post-hook "\" took " (- (current-seconds) start-time) " seconds to run.")))))) | < < < < | 268 269 270 271 272 273 274 275 276 277 278 279 280 281 | (print-call-chain *default-log-port*) (debug:print 0 *default-log-port* "Message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 0 *default-log-port* "ERROR: failed to run post-hook " run-post-hook ", check the log " log-file)) (debug:print-info 0 *default-log-port* "running run-post-hook: \"" run-post-hook "\", log is " actual-logf) (system (conc run-post-hook " >> " actual-logf " 2>&1")) (debug:print-info 0 *default-log-port* "post-hook \"" run-post-hook "\" took " (- (current-seconds) start-time) " seconds to run.")))))) ;;====================================================================== ;; 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 |
︙ | ︙ |
Modified runsmod.scm from [0a1360fd37] to [1824dc688c].
︙ | ︙ | |||
16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit runsmod)) (declare (uses commonmod)) (module runsmod * (import scheme chicken data-structures extras) (import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable) (import commonmod) ;; (use (prefix ulex ulex:)) ;; (include "common_records.scm") (defstruct runs:dat reglen regfull runname max-concurrent-jobs run-id test-patts required-tests test-registry | > > | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | ;; You should have received a copy of the GNU General Public License ;; along with Megatest. If not, see <http://www.gnu.org/licenses/>. ;;====================================================================== (declare (unit runsmod)) (declare (uses commonmod)) (declare (uses testsmod)) (module runsmod * (import scheme chicken data-structures extras) (import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable) (import commonmod) (import testsmod) ;; (use (prefix ulex ulex:)) ;; (include "common_records.scm") (defstruct runs:dat reglen regfull runname max-concurrent-jobs run-id test-patts required-tests test-registry |
︙ | ︙ | |||
87 88 89 90 91 92 93 94 | (let ((lasttime (hash-table-ref/default *runs:denoise* key 0)) (currtime (current-seconds))) (if (> (- currtime lasttime) waitval) (begin (hash-table-set! *runs:denoise* key currtime) #t) #f))) | > > > | > | 89 90 91 92 93 94 95 96 97 98 99 100 101 | (let ((lasttime (hash-table-ref/default *runs:denoise* key 0)) (currtime (current-seconds))) (if (> (- currtime lasttime) waitval) (begin (hash-table-set! *runs:denoise* key currtime) #t) #f))) ;; 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))) ) |
Modified tests-inc.scm from [7718906378] to [6c6c30adad].
︙ | ︙ | |||
18 19 20 21 22 23 24 | ;; ;;====================================================================== ;;====================================================================== ;; Tests ;;====================================================================== | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | ;; ;;====================================================================== ;;====================================================================== ;; Tests ;;====================================================================== ;; return items given config ;; (define (tests:get-items tconfig) (let ((items (hash-table-ref/default tconfig "items" #f)) ;; items 4 (itemstable (hash-table-ref/default tconfig "itemstable" #f))) ;; if either items or items table is a proc return it so test running ;; process can know to call items:get-items-from-config |
︙ | ︙ | |||
193 194 195 196 197 198 199 | #t (begin (debug:print-error 0 *default-log-port* "test " test-name " has unrecognised waiton testname " x) #f))) newwaitors) config))))) | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | #t (begin (debug:print-error 0 *default-log-port* "test " test-name " has unrecognised waiton testname " x) #f))) newwaitors) config))))) ;; Check for waiver eligibility ;; (define (tests:check-waiver-eligibility testdat prev-testdat) (let* ((test-registry (make-hash-table)) (testconfig (tests:get-testconfig (db:test-get-testname testdat) (db:test-get-item-path testdat) test-registry #f)) (test-rundir ;; (sdb:qry 'passstr (db:test-get-rundir testdat)) ;; ) |
︙ | ︙ |
Modified testsmod.scm from [0dd4b074e4] to [12c4abfdd3].
︙ | ︙ | |||
21 22 23 24 25 26 27 | (declare (unit testsmod)) (declare (uses commonmod)) (module testsmod * (import scheme chicken data-structures extras) | > | > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 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 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 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 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 | (declare (unit testsmod)) (declare (uses commonmod)) (module testsmod * (import scheme chicken data-structures extras) (import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69 format ports srfi-1 matchable (prefix mtconfigf configf:) regex srfi-13 ) (import commonmod) ;; (use (prefix ulex ulex:)) (define *java-script-lib* #f) (define (init-java-script-lib) (set! *java-script-lib* (conc (common:get-install-area) "/share/js/jquery-3.1.0.slim.min.js")) ) ;; A routine to map itempaths using a itemmap ;; patha and pathb must be strings or this will fail ;; ;; path-b is waiting on path-a ;; (define (db:compare-itempaths test-b-name path-a path-b itemmaps ) (debug:print-info 6 *default-log-port* "ITEMMAPS: " itemmaps) (let* ((itemmap (tests:lookup-itemmap itemmaps test-b-name))) (if itemmap (let ((path-b-mapped (db:multi-pattern-apply path-b itemmap))) (debug:print-info 6 *default-log-port* "ITEMMAP is " itemmap ", path: " path-b ", mapped path: " path-b-mapped) (equal? path-a path-b-mapped)) (equal? path-b path-a)))) ;; A routine to convert test/itempath using a itemmap ;; NOTE: to process only an itempath (i.e. no prepended testname) ;; just call db:multi-pattern-apply ;; (define (db:convert-test-itempath path-in itemmap) (debug:print-info 6 *default-log-port* "ITEMMAP is " itemmap) (let* ((path-parts (string-split path-in "/")) (test-name (if (null? path-parts) "" (car path-parts))) (item-path (string-intersperse (if (null? path-parts) '() (cdr path-parts)) "/"))) (conc test-name "/" (db:multi-pattern-apply item-path itemmap)))) ;;====================================================================== ;; Run keys, these are used to hierarchially organise tests and run areas ;;====================================================================== (define (keys->keystr keys) ;; => key1,key2,key3,additiona1, ... (string-intersperse keys ",")) (define (args:usage . a) #f) ;;====================================================================== ;; key <=> target routines ;;====================================================================== ;; This invalidates using "/" in item names. Every key will be ;; available via args:get-arg as :keyfield. Since this only needs to ;; be called once let's use it to set the environment vars ;; ;; The setting of :keyfield in args should be turned off ASAP ;; (define (keys:target-set-args keys target ht) (if target (let ((vals (string-split target "/"))) (if (eq? (length vals)(length keys)) (for-each (lambda (key val) (setenv key val) (if ht (hash-table-set! ht (conc ":" key) val))) keys vals) (debug:print-error 0 *default-log-port* "wrong number of values in " target ", should match " keys)) vals) (debug:print 4 *default-log-port* "ERROR: keys:target-set-args called with no target."))) ;; given the keys (a list of vectors <key field> or a list of keys) and a target return a keyval list ;; keyval list ( (key1 val1) (key2 val2) ...) (define (keys:target->keyval keys target) (let* ((targlist (string-split target "/")) (numkeys (length keys)) (numtarg (length targlist)) (targtweaked (if (> numkeys numtarg) (append targlist (make-list (- numkeys numtarg) "")) targlist))) (map (lambda (key targ) (list key targ)) keys targtweaked))) ;;====================================================================== ;; config file related routines ;;====================================================================== (define keys:config-get-fields common:get-fields) (define (keys:make-key/field-string confdat) (let ((fields (configf:get-section confdat "fields"))) (string-join (map (lambda (field)(conc (car field) " " (cadr field))) fields) ","))) ;; patterns are: ;; "rx1" "replacement1"\n ;; "rx2" "replacement2" ;; etc. ;; (define (db:multi-pattern-apply item-path itemmap) (let ((all-patts (string-split itemmap "\n"))) (if (null? all-patts) item-path (let loop ((hed (car all-patts)) (tal (cdr all-patts)) (res item-path)) (let* ((parts (string-split hed)) (patt (car parts)) (repl (if (> (length parts) 1)(cadr parts) "")) (newr (if (and patt repl) (begin (handle-exceptions exn (begin (debug:print 0 *default-log-port* "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl) res) (string-substitute patt repl res)) ) (begin (debug:print 0 *default-log-port* "WARNING: itemmap has problem \"" itemmap "\", patt: " patt ", repl: " repl) res)))) (if (null? tal) newr (loop (car tal)(cdr tal) newr))))))) ;; given waiting-test that is waiting on waiton-test extend test-patt appropriately ;; ;; genlib/testconfig sim/testconfig ;; genlib/sch sim/sch/cell1 ;; ;; [requirements] [requirements] ;; mode itemwait ;; # trim off the cell to determine what to run for genlib ;; itemmap /.* ;; ;; waiting-test is waiting on waiton-test so we need to create a pattern for waiton-test given waiting-test and itemmap ;; BB> (tests:extend-test-patts "normal-second/2" "normal-second" "normal-first" '()) ;; observed -> "normal-first/2,normal-first/,normal-second/2,normal-second/" ;; expected -> "normal-first,normal-second/2,normal-second/" ;; testpatt = normal-second/2 ;; waiting-test = normal-second ;; waiton-test = normal-first ;; itemmaps = () (define (tests:extend-test-patts test-patt waiting-test waiton-test itemmaps itemized-waiton) (cond (itemized-waiton (let* ((itemmap (tests:lookup-itemmap itemmaps waiton-test)) (patts (string-split test-patt ",")) (waiting-test-len (+ (string-length waiting-test) 1)) (patts-waiton (map (lambda (x) ;; for each incoming patt that matches the waiting test (let* ((modpatt (if itemmap (db:convert-test-itempath x itemmap) x)) (newpatt (conc waiton-test "/" (substring modpatt waiting-test-len (string-length modpatt))))) ;; (conc waiting-test "/," waiting-test "/" (substring modpatt waiton-test-len (string-length modpatt))))) ;; (print "in map, x=" x ", newpatt=" newpatt) newpatt)) (filter (lambda (x) (eq? (substring-index (conc waiting-test "/") x) 0)) ;; is this patt pertinent to the waiting test patts))) (extended-test-patt (append patts (if (null? patts-waiton) (list (conc waiton-test "/%")) ;; really shouldn't add the waiton forcefully like this patts-waiton))) (extended-test-patt-with-toplevels (fold (lambda (testpatt-item accum ) (let ((my-match (string-match "^([^%\\/]+)\\/.+$" testpatt-item))) (cons testpatt-item (if my-match (cons (conc (cadr my-match) "/") accum) accum)))) '() extended-test-patt))) (string-intersperse (delete-duplicates extended-test-patt-with-toplevels) ","))) (else ;; not waiting on items, waiting on entire waiton test. (let* ((patts (string-split test-patt ",")) (new-patts (if (member waiton-test patts) patts (cons waiton-test patts)))) (string-intersperse (delete-duplicates new-patts) ","))))) ;; tests:glob-like-match (define (tests:glob-like-match patt str) (let ((like (substring-index "%" patt))) (let* ((notpatt (equal? (substring-index "~" patt) 0)) (newpatt (if notpatt (substring patt 1) patt)) (finpatt (if like (string-substitute (regexp "%") ".*" newpatt #f) (string-substitute (regexp "\\*") ".*" newpatt #f))) (res #f)) ;; (print "tests:glob-like-match => notpatt: " notpatt ", newpatt: " newpatt ", finpatt: " finpatt) (set! res (string-match (regexp finpatt (if like #t #f)) str)) (if notpatt (not res) res)))) ;; if itempath is #f then look only at the testname part ;; (define (tests:match patterns testname itempath #!key (required '())) (if (string? patterns) (let ((patts (append (string-split patterns ",") required))) (if (null? patts) ;;; no pattern(s) means no match #f (let loop ((patt (car patts)) (tal (cdr patts))) ;; (print "loop: patt: " patt ", tal " tal) (if (string=? patt "") #f ;; nothing ever matches empty string - policy (let* ((patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") patt)) (test-patt (cadr patt-parts)) (item-patt (cadddr patt-parts))) ;; special case: test vs. test/ ;; test => "test" "%" ;; test/ => "test" "" (if (and (not (substring-index "/" patt)) ;; no slash in the original (or (not item-patt) (equal? item-patt ""))) ;; should always be true that item-patt is "" (set! item-patt "%")) ;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt) (if (and (tests:glob-like-match test-patt testname) (or (not itempath) (tests:glob-like-match (if item-patt item-patt "") itempath))) #t (if (null? tal) #f (loop (car tal)(cdr tal))))))))))) ;; if itempath is #f then look only at the testname part ;; (define (tests:match->sqlqry patterns) (if (string? patterns) (let ((patts (string-split patterns ","))) (if (null? patts) ;;; no pattern(s) means no match, we will do no query #f (let loop ((patt (car patts)) (tal (cdr patts)) (res '())) ;; (print "loop: patt: " patt ", tal " tal) (let* ((patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") patt)) (test-patt (cadr patt-parts)) (item-patt (cadddr patt-parts)) (test-qry (db:patt->like "testname" test-patt)) (item-qry (db:patt->like "item_path" item-patt)) (qry (conc "(" test-qry " AND " item-qry ")"))) ;; (print "tests:match => patt-parts: " patt-parts ", test-patt: " test-patt ", item-patt: " item-patt) (if (null? tal) (string-intersperse (append (reverse res)(list qry)) " OR ") (loop (car tal)(cdr tal)(cons qry res))))))) #f)) ;; keys list to key1,key2,key3 ... (define (runs:get-std-run-fields keys remfields) (let* ((header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (list keystr header))) ;; make a query (fieldname like 'patt1' OR fieldname (define (db:patt->like fieldname pattstr #!key (comparator " OR ")) (let ((patts (if (string? pattstr) (string-split pattstr ",") '("%")))) (string-intersperse (map (lambda (patt) (let ((wildtype (if (substring-index "%" patt) "LIKE" "GLOB"))) (conc fieldname " " wildtype " '" patt "'"))) (if (null? patts) '("") patts)) comparator))) ;; Call this one to do all the work and get a standardized list of tests ;; gets paths from configs and finds valid tests ;; returns hash of testname --> fullpath ;; (define (tests:get-all) (let* ((test-search-path (tests:get-tests-search-path *configdat*))) (tests:get-valid-tests (make-hash-table) test-search-path))) (define (tests:get-tests-search-path cfgdat) (let ((paths (let ((section (if cfgdat (configf:get-section cfgdat "tests-paths") #f))) (if section (map cadr section) '())))) (filter (lambda (d) (if (directory-exists? d) d (begin (if (common:low-noise-print 60 "tests:get-tests-search-path" d) (debug:print 0 *default-log-port* "WARNING: problem with directory " d ", dropping it from tests path")) #f))) (append paths (list (conc *toppath* "/tests")))))) (define (tests:get-valid-tests test-registry tests-paths) (if (null? tests-paths) test-registry (let loop ((hed (car tests-paths)) (tal (cdr tests-paths))) (if (common:file-exists? hed) (for-each (lambda (test-path) (let* ((tname (last (string-split test-path "/"))) (tconfig (conc test-path "/testconfig"))) (if (and (not (hash-table-ref/default test-registry tname #f)) (common:file-exists? tconfig)) (hash-table-set! test-registry tname test-path)))) (glob (conc hed "/*")))) (if (null? tal) test-registry (loop (car tal)(cdr tal)))))) (define (tests:filter-test-names-not-matched test-names test-patts) (delete-duplicates (filter (lambda (testname) (not (tests:match test-patts testname #f))) test-names))) (define (tests:filter-test-names test-names test-patts) (delete-duplicates (filter (lambda (testname) (tests:match test-patts testname #f)) test-names))) ;; itemmap is a list of testname patterns to maps ;; test1 .*/bar/(\d+) foo/\1 ;; % foo/([^/]+) \1/bar ;; ;; # NOTE: the line with the single % could be the result of ;; # itemmap entry in requirements (legacy). The itemmap ;; # requirements entry is deprecated ;; (define (tests:get-itemmaps tconfig) (let ((base-itemmap (configf:lookup tconfig "requirements" "itemmap")) (itemmap-table (configf:get-section tconfig "itemmap"))) (append (if base-itemmap (list (list "%" base-itemmap)) '()) (if itemmap-table itemmap-table '())))) ;; given a list of itemmaps (testname . map), return the first match ;; (define (tests:lookup-itemmap itemmaps testname) (let ((best-matches (filter (lambda (itemmap) (tests:match (car itemmap) testname #f)) itemmaps))) (if (null? best-matches) #f (let ((res (car best-matches))) ;; (debug:print 0 *default-log-port* "res=" res) (cond ((string? res) res) ;;; FIX THE ROOT CAUSE HERE .... ((null? res) #f) ((string? (cdr res)) (cdr res)) ;; it is a pair ((string? (cadr res))(cadr res)) ;; it is a list (else cadr res)))))) ) |