Changes In Branch v1.64-new-pkts Through [a0adf06969] Excluding Merge-Ins
This is equivalent to a diff from 77f7d5ef17 to a0adf06969
2017-03-16
| ||
23:14 | Corrected logic on extracting spec for linktree check-in: 70a3e1afba user: matt tags: v1.64-new-pkts | |
20:57 | Make linktree default to MT_RUN_AREA_HOME/lt and a linktree setting is no longer needed in megatest.config. check-in: a0adf06969 user: matt tags: v1.64-new-pkts | |
18:05 | Adapt to refactored pkts egg. check-in: 8a6b4757c8 user: matt tags: v1.64-new-pkts | |
2017-03-15
| ||
23:44 | Cleaned up after bug squishing. Several minor bugs found. Added all-rmt unit test and made it the default sole unit flow to run Closed-Leaf check-in: 77f7d5ef17 user: matt tags: v1.64-bug-sqlish | |
21:14 | bug squashing frenzy using overriding of handle-exceptions to expose problems. partial progress snapshot check-in: 8e70f505b7 user: matt tags: v1.64-bug-sqlish | |
Modified archive.scm from [31c5249136] to [7dd47285c1].
︙ | ︙ | |||
109 110 111 112 113 114 115 | (archive-info (archive:allocate-new-archive-block *toppath* (common:get-testsuite-name) min-space)) (archive-dir (if archive-info (cdr archive-info) #f)) (archive-id (if archive-info (car archive-info) -1)) (disk-groups (make-hash-table)) (test-groups (make-hash-table)) ;; these two (disk and test groups) could be combined nicely (bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) (compress (or (configf:lookup *configdat* "archive" "compress") "9")) | | | 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 | (archive-info (archive:allocate-new-archive-block *toppath* (common:get-testsuite-name) min-space)) (archive-dir (if archive-info (cdr archive-info) #f)) (archive-id (if archive-info (car archive-info) -1)) (disk-groups (make-hash-table)) (test-groups (make-hash-table)) ;; these two (disk and test groups) could be combined nicely (bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) (compress (or (configf:lookup *configdat* "archive" "compress") "9")) (linktree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree"))) (if (not archive-dir) ;; no archive disk found, this is fatal (begin (debug:print 0 *default-log-port* "FATAL: No archive disks found. Please add disks with at least " min-space " MB space to the [archive-disks] section of megatest.config") (debug:print 0 *default-log-port* " use [archive] minspace to specify minimum available space") (debug:print 0 *default-log-port* " disks: " (string-intersperse (map cadr (archive:get-archive-disks)) "\n ")) (exit 1)) |
︙ | ︙ | |||
209 210 211 212 213 214 215 | (hash-table-keys disk-groups)) #t)) (define (archive:bup-restore archive-command run-id run-name tests rp-mutex bup-mutex) ;; move the getting of archive space down into the below block so that a single run can ;; allocate as needed should a disk fill up ;; (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) | | | 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 | (hash-table-keys disk-groups)) #t)) (define (archive:bup-restore archive-command run-id run-name tests rp-mutex bup-mutex) ;; move the getting of archive space down into the below block so that a single run can ;; allocate as needed should a disk fill up ;; (let* ((bup-exe (or (configf:lookup *configdat* "archive" "bup") "bup")) (linktree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree"))) ;; from the test info bin the path to the test by stem ;; (for-each (lambda (test-dat) ;; When restoring test-dat will initially contain an old and invalid path to the test (let* ((best-disk (get-best-disk *configdat* #f)) ;; BUG: get the testconfig and use it here. Otherwise data pulled out of archive could end up on the wrong kind of disk. |
︙ | ︙ |
Modified common.scm from [cb8fbcb993] to [f744741851].
︙ | ︙ | |||
951 952 953 954 955 956 957 | (debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt) rtestpatt) (else args-testpatt)))) (define (common:get-linktree) (or (getenv "MT_LINKTREE") (if *configdat* | | > > > | 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 | (debug:print-info 0 *default-log-port* "testpatt defined in "testpatt-key" from runconfigs: " rtestpatt) rtestpatt) (else 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)) |
︙ | ︙ |
Modified http-transport.scm from [91a7291a41] to [a75c26faf4].
︙ | ︙ | |||
55 56 57 58 59 60 61 | (hostname (get-host-name)) (ipaddrstr (let ((ipstr (if (string=? "-" hostn) ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") (server:get-best-guess-address hostname) #f))) (if ipstr ipstr hostn))) ;; hostname))) (start-port (portlogger:open-run-close portlogger:find-port)) | | | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 | (hostname (get-host-name)) (ipaddrstr (let ((ipstr (if (string=? "-" hostn) ;; (string-intersperse (map number->string (u8vector->list (hostname->ip hostname))) ".") (server:get-best-guess-address hostname) #f))) (if ipstr ipstr hostn))) ;; hostname))) (start-port (portlogger:open-run-close portlogger:find-port)) (link-tree-path (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree"))) (debug:print-info 0 *default-log-port* "portlogger recommended port: " start-port) (root-path (if link-tree-path link-tree-path (current-directory))) ;; WARNING: SECURITY HOLE. FIX ASAP! (handle-directory spiffy-directory-listing) (handle-exception (lambda (exn chain) (signal (make-composite-condition |
︙ | ︙ |
Modified launch.scm from [e503042943] to [93db933159].
︙ | ︙ | |||
574 575 576 577 578 579 580 | (list "MT_TEST_RUN_DIR" work-area) (list "MT_TEST_NAME" test-name) (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_ITEMPATH" item-path) (list "MT_RUNNAME" runname) (list "MT_MEGATEST" megatest) (list "MT_TARGET" target) | | | 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 | (list "MT_TEST_RUN_DIR" work-area) (list "MT_TEST_NAME" test-name) (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_ITEMPATH" item-path) (list "MT_RUNNAME" runname) (list "MT_MEGATEST" megatest) (list "MT_TARGET" target) (list "MT_LINKTREE" (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")) (list "MT_TESTSUITENAME" (common:get-testsuite-name)))) (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))) ;; (change-directory top-path) ;; Can setup as client for server mode now ;; (client:setup) |
︙ | ︙ | |||
680 681 682 683 684 685 686 | (define (launch:cache-config) ;; if we have a linktree and -runtests and -target and the directory exists dump the config ;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg (if (and *configdat* (or (args:get-arg "-run") (args:get-arg "-runtests") (args:get-arg "-execute"))) | | | 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 | (define (launch:cache-config) ;; if we have a linktree and -runtests and -target and the directory exists dump the config ;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg (if (and *configdat* (or (args:get-arg "-run") (args:get-arg "-runtests") (args:get-arg "-execute"))) (let* ((linktree (common:get-linktree)) ;; (get-environment-variable "MT_LINKTREE")) (target (common:args-get-target exit-if-bad: #t)) (runname (or (args:get-arg "-runname") (args:get-arg ":runname") (getenv "MT_RUNNAME"))) (fulldir (conc linktree "/" target "/" runname))) |
︙ | ︙ | |||
799 800 801 802 803 804 805 | (debug:print-error 0 *default-log-port* "you are not in a megatest area!") (exit 1))) (setenv "MT_RUN_AREA_HOME" *toppath*) ;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it (let* ((keys (rmt:get-keys)) (key-vals (keys:target->keyval keys target)) (linktree (or (getenv "MT_LINKTREE") | > | > | 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 | (debug:print-error 0 *default-log-port* "you are not in a megatest area!") (exit 1))) (setenv "MT_RUN_AREA_HOME" *toppath*) ;; the seed read is done, now read runconfigs, cache it then read megatest.config one more time and cache it (let* ((keys (rmt:get-keys)) (key-vals (keys:target->keyval keys target)) (linktree (or (getenv "MT_LINKTREE") (if *configdat* (configf:lookup *configdat* "setup" "linktree") (conc *toppath* "/lt")))) (second-pass (find-and-read-config mtconfig environ-patt: "env-override" given-toppath: toppath pathenvvar: "MT_RUN_AREA_HOME")) (runconfigdat (begin ;; this read of the runconfigs will see any adjustments made by re-reading megatest.config (for-each (lambda (kt) |
︙ | ︙ | |||
838 839 840 841 842 843 844 | (set! *runconfigdat* rdat) (set! *toppath* toppath) (set! *configstatus* 'partial)) (begin (debug:print-error 0 *default-log-port* "No " mtconfig " file found. Giving up.") (exit 2)))))) ;; additional house keeping | | < | 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 | (set! *runconfigdat* rdat) (set! *toppath* toppath) (set! *configstatus* 'partial)) (begin (debug:print-error 0 *default-log-port* "No " mtconfig " file found. Giving up.") (exit 2)))))) ;; additional house keeping (let* ((linktree (common:get-linktree))) (if linktree (begin (if (not (file-exists? linktree)) (begin (handle-exceptions exn (begin |
︙ | ︙ | |||
930 931 932 933 934 935 936 | (test-base (conc testtop-base (if not-iterated "" "/") item-path)) ;; nb// if itempath is not "" then it is prefixed with "/" (toptest-path (conc disk-path (if contour (conc "/" contour) "") "/" testtop-base)) (test-path (conc disk-path (if contour (conc "/" contour) "") "/" test-base)) ;; ensure this exists first as links to subtests must be created there | > | | > | 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 | (test-base (conc testtop-base (if not-iterated "" "/") item-path)) ;; nb// if itempath is not "" then it is prefixed with "/" (toptest-path (conc disk-path (if contour (conc "/" contour) "") "/" testtop-base)) (test-path (conc disk-path (if contour (conc "/" contour) "") "/" test-base)) ;; ensure this exists first as links to subtests must be created there (linktree (common:get-linktree)) ;; WAS: (let ((rd (config-lookup *configdat* "setup" "linktree"))) ;; (if rd rd (conc *toppath* "/runs")))) ;; which seems wrong ... (lnkbase (conc linktree (if contour (conc "/" contour) "") "/" target "/" runname)) (lnkpath (conc lnkbase "/" testname)) (lnkpathf (conc lnkpath (if not-iterated "" "/") item-path)) (lnktarget (conc lnkpath "/" item-path))) ;; Update the rundir path in the test record for all, rundir=physical, shortdir=logical |
︙ | ︙ |
Modified megatest.scm from [95c7d4b1ae] to [45d18034d7].
︙ | ︙ | |||
524 525 526 527 528 529 530 | ;; (if (args:get-arg "-clean-cache") (begin (set! *didsomething* #t) ;; suppress the help output. (if (getenv "MT_TARGET") ;; no point in trying if no target (if (args:get-arg "-runname") (let* ((toppath (launch:setup)) | | | 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 | ;; (if (args:get-arg "-clean-cache") (begin (set! *didsomething* #t) ;; suppress the help output. (if (getenv "MT_TARGET") ;; no point in trying if no target (if (args:get-arg "-runname") (let* ((toppath (launch:setup)) (linktree (common:get-linktree)) ;; (if toppath (configf:lookup *configdat* "setup" "linktree"))) (runtop (conc linktree "/" (getenv "MT_TARGET") "/" (args:get-arg "-runname"))) (files (if (file-exists? runtop) (append (glob (conc runtop "/.megatest*")) (glob (conc runtop "/.runconfig*"))) '()))) (if (null? files) (debug:print-info 0 *default-log-port* "No cached megatest or runconfigs files found. None removed.") |
︙ | ︙ |
Modified mt.scm from [0a710abd80] to [410c526eee].
︙ | ︙ | |||
206 207 208 209 210 211 212 | (let ((test-dirs (tests:get-tests-search-path *configdat*))) (let loop ((hed (car test-dirs)) (tal (cdr test-dirs))) ;; Setting MT_LINKTREE here is almost certainly unnecessary. (let ((tconfig-file (conc hed "/" test-name "/testconfig"))) (if (and (file-exists? tconfig-file) (file-read-access? tconfig-file)) | | | 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 | (let ((test-dirs (tests:get-tests-search-path *configdat*))) (let loop ((hed (car test-dirs)) (tal (cdr test-dirs))) ;; Setting MT_LINKTREE here is almost certainly unnecessary. (let ((tconfig-file (conc hed "/" test-name "/testconfig"))) (if (and (file-exists? tconfig-file) (file-read-access? tconfig-file)) (let ((link-tree-path (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")) (old-link-tree (get-environment-variable "MT_LINKTREE"))) (if link-tree-path (setenv "MT_LINKTREE" link-tree-path)) (let ((newtcfg (read-config tconfig-file #f #f))) ;; NOTE: Does NOT run [system ...] (hash-table-set! *testconfigs* test-name newtcfg) (if old-link-tree (setenv "MT_LINKTREE" old-link-tree) (unsetenv "MT_LINKTREE")) |
︙ | ︙ |
Modified mtut.scm from [fdb1ede093] to [9e88c442a2].
︙ | ︙ | |||
10 11 12 13 14 15 16 | ;; (include "common.scm") ;; (include "megatest-version.scm") ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) (use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras) | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | ;; (include "common.scm") ;; (include "megatest-version.scm") ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) (use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras) srfi-18 extras format pkts pkts regex regex-case (prefix dbi dbi:)) ;; zmq extras) (declare (uses common)) (declare (uses megatest-version)) (declare (uses margs)) (declare (uses configf)) ;; (declare (uses rmt)) |
︙ | ︙ | |||
341 342 343 344 345 346 347 | (lambda (pkt) (let* ((uuid (cadr (string-match ".*/([0-9a-f]+).pkt" pkt))) (exists (lookup-by-uuid pdb uuid #f))) (if (not exists) (let* ((pktdat (string-intersperse (with-input-from-file pkt read-lines) "\n")) | | | | 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 | (lambda (pkt) (let* ((uuid (cadr (string-match ".*/([0-9a-f]+).pkt" pkt))) (exists (lookup-by-uuid pdb uuid #f))) (if (not exists) (let* ((pktdat (string-intersperse (with-input-from-file pkt read-lines) "\n")) (apkt (pkt->alist pktdat)) (ptype (alist-ref 'T apkt))) (add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0) (debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue")) (debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...") ))) pkts)))) (string-split pktsdirs))))) (define (get-pkt-alists pkts) (map (lambda (x) (alist-ref 'apkt x)) ;; 'pkta pulls out the alist from the read pkt pkts)) ;; given list of pkts (alist mode) return list of D cards as Unix epoch, sorted descending ;; also delete duplicates by target i.e. (car pkt) (define (get-pkt-times pkts) (delete-duplicates (sort |
︙ | ︙ | |||
760 761 762 763 764 765 766 | (fold (lambda (a res) (let* ((key (car a)) ;; get the key name (val (cdr a)) (par (lookup-param-by-key key))) ;; (print "key: " key " val: " val " par: " par) (if par (conc res " " (param-translate par) " " val) | | | 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 | (fold (lambda (a res) (let* ((key (car a)) ;; get the key name (val (cdr a)) (par (lookup-param-by-key key))) ;; (print "key: " key " val: " val " par: " par) (if par (conc res " " (param-translate par) " " val) (if (member key '(a Z U D T)) ;; a is the action res (begin (print "ERROR: Unknown key in packet \"" key "\" with value \"" val "\"") res))))) (conc "megatest " (if (not (member action '("sync"))) (conc action " ") "")) |
︙ | ︙ | |||
806 807 808 809 810 811 812 | (areas (configf:get-section mtconf "areas")) (contours (configf:get-section mtconf "contours")) (pkts (find-pkts pdb '(cmd) '())) (torun (make-hash-table)) ;; target => ( ... info ... ) (rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering (for-each (lambda (pktdat) | | | 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 | (areas (configf:get-section mtconf "areas")) (contours (configf:get-section mtconf "contours")) (pkts (find-pkts pdb '(cmd) '())) (torun (make-hash-table)) ;; target => ( ... info ... ) (rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering (for-each (lambda (pktdat) (let* ((pkta (alist-ref 'apkt pktdat)) (action (alist-ref 'a pkta)) (cmdline (pkt->cmdline pkta)) (uuid (alist-ref 'Z pkta)) (logf (conc logdir "/" uuid "-run.log")) (fullcmd (conc "NBFAKE_LOG=" logf " nbfake " cmdline))) (print "RUNNING: " fullcmd) (system fullcmd) |
︙ | ︙ |
Modified runs.scm from [a2e7cae34f] to [36a33c3dbc].
︙ | ︙ | |||
54 55 56 57 58 59 60 | (define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f)) (let* ((target (or intarget (common:args-get-target) (get-environment-variable "MT_TARGET"))) (keys (if inkeys inkeys (rmt:get-keys))) (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target))) (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f)) | | | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 | (define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f)) (let* ((target (or intarget (common:args-get-target) (get-environment-variable "MT_TARGET"))) (keys (if inkeys inkeys (rmt:get-keys))) (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target))) (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f)) (link-tree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree"))) (if testname (setenv "MT_TEST_NAME" testname)) (if itempath (setenv "MT_ITEMPATH" itempath)) ;; get the info from the db and put it in the cache (if link-tree (setenv "MT_LINKTREE" link-tree) (debug:print-error 0 *default-log-port* "linktree not set, should be set in megatest.config in [setup] section.")) |
︙ | ︙ |
Modified tasks.scm from [3a8b93e01e] to [9d362c0818].
︙ | ︙ | |||
58 59 60 61 62 63 64 | (if remove (system (conc "rm -rf " fullpath))) #f))) #t)))))) (define (tasks:get-task-db-path) (let ((dbdir (or (configf:lookup *configdat* "setup" "monitordir") (configf:lookup *configdat* "setup" "dbdir") | | | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 | (if remove (system (conc "rm -rf " fullpath))) #f))) #t)))))) (define (tasks:get-task-db-path) (let ((dbdir (or (configf:lookup *configdat* "setup" "monitordir") (configf:lookup *configdat* "setup" "dbdir") (conc (common:get-linktree) "/.db")))) (handle-exceptions exn (begin (debug:print-error 0 *default-log-port* "Couldn't create path to " dbdir) (exit 1)) (if (not (directory? dbdir))(create-directory dbdir #t))) dbdir)) |
︙ | ︙ |