Megatest

Check-in [ed85670974]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:installed all changes from branch v1.8031
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.80
Files: files | file ages | folders
SHA1: ed8567097430ce7e0ea71f9238b682e253240a93
User & Date: mmgraham on 2024-05-09 07:49:03
Other Links: branch diff | manifest | tags
Context
2024-05-10
10:37
merged fork check-in: 545db1f8c6 user: mmgraham tags: v1.80
2024-05-09
07:49
installed all changes from branch v1.8031 check-in: ed85670974 user: mmgraham tags: v1.80
2024-05-07
16:39
Cherry picked postcmd and precmd for tests check-in: 40cce970c0 user: mrwellan tags: v1.80
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified common.scm from [0854266963] to [a6df612234].

︙
41
42
43
44
45
46
47
48

49
50
51
52
53
54
55

41
42
43
44
45
46
47

48
49
50
51
52
53
54
55








-
+








	rmtmod
	(prefix mtargs args:))

(include "common_records.scm")

(define (remove-files filespec)
  (let ((files (glob filespec)))
    (for-each delete-file files)))
    (for-each delete-file* files)))

(define (stop-the-train)
  (thread-start! (make-thread (lambda ()
				(let loop ()
				  (if (and *toppath*
					   (file-exists? (conc *toppath*"/stop-the-train")))
				      (let* ((msg (conc "ERROR: found file "*toppath*"/stop-the-train, exiting immediately")))
︙

Modified dashboard.scm from [2fba186660] to [6ea3e152b3].

︙
3826
3827
3828
3829
3830
3831
3832

3833

3834
3835
3836
3837
3838
3839
3840

3826
3827
3828
3829
3830
3831
3832
3833

3834
3835
3836
3837
3838
3839
3840
3841








+
-
+








  ;; (print "Starting dashboard main")
    
  (let* ((mtdb-path (conc *toppath* "/.mtdb/main.db"))
         (target (args:get-arg "-target"))
         (commondat       (dboard:commondat-make)))
    (if target
        (begin
          (hash-table-delete! args:arg-hash "-target")  ;; workaround for the following commented out function
          (args:remove-arg-from-ht "-target")
          ;; (args:remove-arg-from-ht "-target")   This function is in mtargs/mtargs.scm, but it's in an egg that is not in the current build of chicken 4.
          (dboard:commondat-target-set! commondat target)
        )
    )

    (if (not (launch:setup))
        (begin
          (debug:print 0 *default-log-port* "Failed to find megatest.config, exiting")
︙

Modified dbfile.scm from [5eebf6582a] to [e2ffa01a50].

︙
444
445
446
447
448
449
450
451


452
453
454
455
456
457
458

444
445
446
447
448
449
450

451
452
453
454
455
456
457
458
459








-
+
+








				 (if sync-mode
				     (sqlite3:execute db (conc "PRAGMA synchronous = "sync-mode";")))
				 (if journal-mode
				     (sqlite3:execute db (conc "PRAGMA journal_mode = "journal-mode";")))
				 (if (and init-proc (or force-init
							(not db-exists)))
				     (init-proc db))
				 db)))
				 db))
                             expire-time: 30)
                            (begin
			      (if (file-exists? fname )
                                  (let ((db (sqlite3:open-database fname)))
				    ;; pragmas synchronous not needed because this db is used read-only
				    ;; (sqlite3:execute db (conc "PRAGMA synchronous = "mode";")
				    (sqlite3:set-busy-handler! db (sqlite3:make-busy-timeout 30000)) ;; read-only but still need timeout
				    db )
︙
1511
1512
1513
1514
1515
1516
1517
1518

1519
1520
1521
1522
1523
1524
1525

1512
1513
1514
1515
1516
1517
1518

1519
1520
1521
1522
1523
1524
1525
1526








-
+








	  (if (file-exists? fname)
	      (handle-exceptions exn
                #f 
                (with-input-from-file fname
	  	  (lambda ()
		    (equal? key-string (read-line)))))
              (begin
                 (dbfile:print-err "dbfile:simple-file-lock created " fname " but it was gone 3 seconds later")
                 (dbfile:print-err "dbfile:simple-file-lock created " fname " but it was gone 0.25 seconds later")
	         #f
              )
          )
       )
    )
  )
)
︙

Modified dbmod.scm from [00037bb607] to [2bc6505880].

︙
520
521
522
523
524
525
526
527

528
529
530
531
532
533
534

520
521
522
523
524
525
526

527
528
529
530
531
532
533
534








-
+








	  ;; for each table
	  ;;    insert into dest.<table> select * from src.<table> where last_update>last_update
	  ;; done
	  (debug:print 2 *default-log-port* "Attaching "destdbfile" as auxdb")
	  (handle-exceptions
	      exn
	      (begin
		(debug:print 0 "ATTACH failed, exiting. exn="(condition->list exn))
		(debug:print 0 *default-log-port* "ATTACH failed, exiting. exn="(condition->list exn))
		(exit 1))
	    (sqlite3:execute dbh (conc "ATTACH '"destdbfile"' AS auxdb;")))
	  (for-each
	   (lambda (table)
	     (let* ((dummy (debug:print 2 *default-log-port* "Doing table " table))
                    (tbldat (alist-ref table tables equal?))
		    (fields (map car tbldat))
︙

Modified launch.scm from [f3e38feb4f] to [34e6bfc4b1].

︙
938
939
940
941
942
943
944
945

946
947
948
949
950
951
952

938
939
940
941
942
943
944

945
946
947
948
949
950
951
952








-
+








		       runname
		       (common:file-exists? fulldir))
		  (let ((tmpfile  (conc fulldir "/.megatest.cfg." (current-seconds)))
			(targfile (conc fulldir "/.megatest.cfg-"  megatest-version "-" megatest-fossil-hash))
			(rconfig  (conc fulldir "/.runconfig." megatest-version "-" megatest-fossil-hash)))
		    (if (common:file-exists? rconfig) ;; only cache megatest.config AFTER runconfigs has been cached
			(begin
			  (debug:print-info 0 *default-log-port* "Caching megatest.config in " tmpfile)
			  (debug:print-info 2 *default-log-port* "Caching megatest.config in " tmpfile)
                          (if (not (common:in-running-test?))
                              (configf:write-alist *configdat* tmpfile))
			  (system (conc "ln -sf " tmpfile " " targfile))))
		    )))
	    (debug:print-info 1 *default-log-port* "No linktree yet, no caching configs.")))))
︙

Modified megatest.scm from [eb152672fe] to [f4be8baece].

︙
109
110
111
112
113
114
115



116




117
118
119
120
121
122
123

109
110
111
112
113
114
115
116
117
118

119
120
121
122
123
124
125
126
127
128
129








+
+
+
-
+
+
+
+








 ;;(lambda params (apply rmt:send-receive params))) ;; make send-receive available to rmtmod via parameter


;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file
;;
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc")))
  (if (common:file-exists? debugcontrolf)
    (begin
      ;; for some reason, debug:print does not work here. Had to use print.
      (print (conc "WARNING: loading " debugcontrolf))
      (load debugcontrolf)))
      (load debugcontrolf)
    )
  )
)

;; usage logging, careful with this, it is not designed to deal with all real world challenges!
;;
(if (and *usage-log-file*
         (file-write-access? *usage-log-file*))
    (with-output-to-file
        *usage-log-file*
︙

Modified mtargs/mtargs.scm from [09e4f74c98] to [c1d2bd2b3a].

︙
18
19
20
21
22
23
24

25
26
27
28
29
30
31

18
19
20
21
22
23
24
25
26
27
28
29
30
31
32








+









(module mtargs
    (
     arg-hash
     get-arg
     get-arg-number
     get-arg-from
     remove-arg-from-ht
     get-args
     usage
     print-args
     any-defined?
     ) 

(import scheme) ;; gives us cond-expand in chicken-4
︙
62
63
64
65
66
67
68




69
70
71
72
73
74
75

63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80








+
+
+
+









;; (define any any-defined?)

(define (get-arg-from ht arg . default)
  (if (null? default)
      (hash-table-ref/default ht arg #f)
      (hash-table-ref/default ht arg (car default))))

(define (remove-arg-from-ht arg)
      (hash-table-delete! arg-hash arg)
)

(define (get-args args params switches arg-hash num-needed)
  (let* ((numtargs (length args))
	 (adj-num-needed (if num-needed (+ num-needed 2) #f)))
    (if (< numtargs (if adj-num-needed adj-num-needed 2))
	(if (>= num-needed 1)
	    (usage "No arguments provided")
︙

Modified portlogger.scm from [3334cefb6f] to [9754766f61].

︙
29
30
31
32
33
34
35
36


37
38
39
40
41
42
43

29
30
31
32
33
34
35

36
37
38
39
40
41
42
43
44








-
+
+








(import srfi-1 posix srfi-69 hostinfo dot-locking z3
	(srfi 18) extras s11n)
(import (prefix sqlite3 sqlite3:))
(import debugprint dbmod)
;; lsof -i

(define (portlogger:open-db fname)
  (let* ((avail    (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away
  (let* (;; (avail    (tasks:wait-on-journal fname 5 remove: #t)) ;; wait up to about 10 seconds for the journal to go away
         (avail #t)
	 (exists   (file-exists? fname))
	 (db       (if avail 
		       (sqlite3:open-database fname)
		       (begin
			 (system (conc "rm -f " fname))
			 (sqlite3:open-database fname))))
	 (handler  (sqlite3:make-busy-timeout 136000))
︙

Modified rmtmod.scm from [c4f748fe17] to [d2f108f299].

︙
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

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








+
+
+
-
-
-
+
+
+

-
-
+
+
+
+
+
+
+














-
-
-
+
+
+
+
+
+
+
+
+
+
+
+









(define (rmt:import-run target run-dat)
  (let* ((runname    (car run-dat))
	 (all-dat    (cdr run-dat))
	 (tests-data (alist-ref "data" all-dat equal?))
	 (run-meta   (alist-ref "meta" all-dat equal?))
	 (run-id     (rmt:insert-run target runname run-meta)))
    (if (list? tests-data)
      (begin
        (debug:print 0 *default-log-port* "import-run: inserting " (length tests-data) " tests")
    (for-each
     (lambda (test-dat)
       (let* ((test-id  (car test-dat))
      (for-each
        (lambda (test-dat)
          (let* ((test-id  (car test-dat))
	      (test-rec (cdr test-dat)))
	 (rmt:insert-test run-id test-rec)))
     tests-data)))
	  (rmt:insert-test run-id test-rec)))
      tests-data)
      )
      (debug:print 0 *default-log-port* "import-run: run has no tests")
    )
  )
)

;; insert run if not there, return id either way
(define (rmt:insert-run target runname run-meta)
  ;; look for id, return if found
  (debug:print 0 *default-log-port* "Insert run: "target"/"runname)
  (let* ((runs (rmtmod:send-receive 'simple-get-runs #f
				    ;;    runpatt count offset target last-update)
				    (list runname #f    #f     target #f))))
    (if (null? runs)
	(rmtmod:send-receive 'insert-run #f (list target runname run-meta))
	(simple-run-id (car runs)))))

(define (rmt:insert-test run-id test-rec)
  (let* ((testname  (alist-ref "testname" test-rec equal?))
	 (item-path (alist-ref "item_path" test-rec equal?)))
    (debug:print 0 *default-log-port* "   Insert test in run "run-id": "testname"/"item-path)
    (rmtmod:send-receive 'insert-test run-id test-rec)))
	 (item-path (alist-ref "item_path" test-rec equal?))
         (test-id (rmt:get-test-id run-id testname item-path))
         )
        (if test-id
          (debug:print 0 *default-log-port* "test "testname"/"item-path " already exists in run-id " run-id)
          (begin
            (debug:print 0 *default-log-port* "   Insert test in run "run-id": "testname"/"item-path)
            (rmtmod:send-receive 'insert-test run-id test-rec)
          )
        )
  )
)

;;======================================================================
;;  T E S T S
;;======================================================================

;; Just some syntatic sugar
(define (rmt:register-test run-id test-name item-path)
︙

Modified runs.scm from [77337ff0b0] to [50ba01f6cc].

︙
2914
2915
2916
2917
2918
2919
2920
2921

2922
2923
2924
2925
2926
2927
2928

2914
2915
2916
2917
2918
2919
2920

2921
2922
2923
2924
2925
2926
2927
2928








-
+








     (lambda (key)
       (let* ((idx (cadr key))
	      (fld (car  key))
	      (val (configf:lookup test-conf "test_meta" fld)))
	 ;; (debug:print 5 *default-log-port* "idx: " idx " fld: " fld " val: " val)
	 (if (and val (not (equal? (vector-ref currrecord idx) val)))
	     (begin
	       (debug:print 0 *default-log-port* "Updating " test-name " " fld " to " val)
	       (debug:print 2 *default-log-port* "Updating " test-name " " fld " to " val)
	       (rmt:testmeta-update-field test-name fld val)))))
     '(("author" 2)("owner" 3)("description" 4)("reviewed" 5)("tags" 9)("jobgroup" 10)))))

;; find tests with matching tags, tagpatt is a string "tagpatt1,tagpatt2%, ..."
;;
(define (runs:get-tests-matching-tags tagpatt)
  (let* ((tagdata (rmt:get-tests-tags))
︙

Modified tcp-transportmod.scm from [157488cd36] to [c81bb58c08].

︙
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763

764
765
766
767
768
769
770
771
772

741
742
743
744
745
746
747


748
749
750
751
752
753
754
755
756
757
758
759
760

761


762
763
764
765
766
767
768








-
-













-
+
-
-









;; given a path to a server info file return: host port startseconds server-id pid dbfname logf
;; example of what it's looking for in the log file:
;;     SERVER STARTED: 10.38.175.67:50216 AT 1616502350.0 server-id: 4907e90fc55c7a09694e3f658c639cf4 
;;
(define (tt:server-get-info logf)
  (let ((server-rx    (regexp "^SERVER STARTED: (\\S+):(\\d+) AT ([\\d\\.]+) server-id: (\\S+) pid: (\\d+) dbfname: (\\S+)")) ;; SERVER STARTED: host:port AT timesecs server id
        (dbprep-rx    (regexp "^SERVER: dbprep"))
        (dbprep-found 0)
	(bad-dat      (list #f #f #f #f #f #f logf)))
     (let ((fdat     (handle-exceptions
			 exn
		       (begin
			 ;; WARNING: this is potentially dangerous to blanket ignore the errors
			 (debug:print-info 0 *default-log-port* "Unable to get server info from "logf", exn="(condition->list exn))
			 '()) ;; no idea what went wrong, call it a bad server, return empty list
		       (with-input-from-file logf read-lines))))
       (if (null? fdat) ;; bad data, return bad-dat
	   bad-dat
	   (let loop ((inl  (car fdat))
		      (tail (cdr fdat))
		      (lnum 0))
	     (let ((mlst (string-match server-rx inl))
	     (let ((mlst (string-match server-rx inl)))
		   (dbprep (string-match dbprep-rx inl)))
	       (if dbprep (set! dbprep-found 1))
	       (if (not mlst)
		   (if (> lnum 500) ;; give up if more than 500 lines of server log read
		       bad-dat
		       (if (null? tail)
			   bad-dat
			   (loop (car tail)(cdr tail)(+ lnum 1))))
		   (match mlst ;; have a not null list
︙
903
904
905
906
907
908
909


910



911
912
913
914
915
916
917

899
900
901
902
903
904
905
906
907

908
909
910
911
912
913
914
915
916
917








+
+
-
+
+
+








    (handle-exceptions
	exn
      (if (< port 65535)
	  (begin
	    (portlogger:open-run-close portlogger:set-failed port)
	    (thread-sleep! 0.25)
	    (setup-listener-portlogger uconn))
          (begin
            (assert #t "setup-listener-portlogger: could not get a port")
	  #f)
	    #f
          )
      )
      (connect-listener uconn port))))

(define (connect-listener uconn port)
  ;; (tcp-listener-socket LISTENER)(socket-name so)
  ;; sockaddr-address, sockaddr-port, sockaddr->string
  (let* ((tlsn (tcp-listen port 10000 #f)) ;; (tcp-listen TCPPORT [BACKLOG [HOST]])
	 (addr  (tt:get-best-guess-address (get-host-name)))) ;; (get-my-best-address))) ;; (hostinfo-addresses (host-information (current-hostname)))
︙

Modified tests.scm from [6fa611f761] to [cc043fc184].

︙
1636
1637
1638
1639
1640
1641
1642
1643

1644
1645
1646
1647
1648
1649
1650

1636
1637
1638
1639
1640
1641
1642

1643
1644
1645
1646
1647
1648
1649
1650








-
+








		(if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data
		(if tcfg (hash-table-set! *testconfigs* test-full-name tcfg))
		(if (and testexists
			 cache-file
			 (file-write-access? cache-path)
			 allow-write-cache)
		    (let ((tpath (conc cache-path "/.testconfig")))
		      (debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath)
		      (debug:print-info 2 *default-log-port* "Caching testconfig for " test-name " in " tpath)
                      (if (and tcfg (not (common:in-running-test?)))
                          (configf:write-alist tcfg tpath))))
		tcfg))))))
  
;; sort tests by priority and waiton
;; Move test specific stuff to a test unit FIXME one of these days
(define (tests:sort-by-priority-and-waiton test-records)
︙

This page was generated in about 0.132s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00