Megatest

Check-in [21ed5f0c54]
Login
Overview
Comment:wip
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.6584-ck5
Files: files | file ages | folders
SHA1: 21ed5f0c540430e2573bc019263db87264e9bc5d
User & Date: matt on 2021-04-14 23:24:14
Other Links: branch diff | manifest | tags
Context
2021-04-14
23:40
wip check-in: 69dd9a8819 user: matt tags: v1.6584-ck5
23:24
wip check-in: 21ed5f0c54 user: matt tags: v1.6584-ck5
23:10
wip check-in: 04d9567700 user: matt tags: v1.6584-ck5
Changes

Deleted margs.scm version [c1ea22878c].

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
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
























































































-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
;; Copyright 2007-2010, Matthew Welland.
;;
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     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/>.


;; (declare (unit margs))
;; (declare (uses common))

(define args:arg-hash (make-hash-table))

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

(define (args:any? . args)
  (not (null? (filter (lambda (x) x)
		      (map args:get-arg args)))))

(define (args: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 (args:usage . args)
  (if (> (length args) 0)
      (apply print "ERROR: " args))
  (if (string? help)
      (print help)
      (print "Usage: " (car (argv)) " ... "))
  (exit 0))

 ;; one-of args defined
(define (args:any-defined? . param)
  (let ((res #f))
    (for-each 
     (lambda (arg)
       (if (args:get-arg arg)(set! res #t)))
     param)
    res))

;; args: 
(define (args:get-args args params switches arg-hash num-needed)
  (let* ((numargs (length args))
	 (adj-num-needed (if num-needed (+ num-needed 2) #f)))
    (if (< numargs (if adj-num-needed adj-num-needed 2))
	(if (>= num-needed 1)
	    (args:usage "No arguments provided")
	    '())
	(let loop ((arg (cadr args))
		   (tail (cddr args))
		   (remargs '()))
	  (cond 
	   ((member arg params) ;; args with params
	    (if (< (length tail) 1)
		(args:usage "param given without argument " arg)
		(let ((val     (car tail))
		      (newtail (cdr tail)))
		  (hash-table-set! arg-hash arg val)
		  (if (null? newtail) remargs
		      (loop (car newtail)(cdr newtail) remargs)))))
	   ((member arg switches)         ;; args with no params (i.e. switches)
	    (hash-table-set! arg-hash arg #t)
	    (if (null? tail) remargs
		(loop (car tail)(cdr tail) remargs)))
	   (else
	    (if (null? tail)(append remargs (list arg)) ;; return the non-used args
		(loop (car tail)(cdr tail)(append remargs (list arg))))))))
    ))

(define (args:print-args remargs arg-hash)
  (print "ARGS: " remargs)
  (for-each (lambda (arg)
	      (print "   " arg "   " (hash-table-ref/default arg-hash arg #f)))
	    (hash-table-keys arg-hash)))

Modified megatest.scm from [7367359acf] to [ea5fd4faeb].

12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
12
13
14
15
16
17
18















19
20
21
22
23
24
25







-
-
-
-
-
-
-
-
-
-
-
-
-
-
-







;;     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/>.
;;

;;  megatest.scm mofiles/autoload.o mofiles/dbi.o mofiles/ducttape-lib.o
;;  mofiles/pkts.o mofiles/stml2.o mofiles/cookie.o mofiles/mutils.o
;;  mofiles/mtargs.o

;; (include "mutils/mutils.scm")
;; (include "autoload/autoload.scm")
;; (include "dbi/dbi.scm")
;; (include "stml2/cookie.scm")
;; (include "stml2/stml2.scm")
;; (include "pkts/pkts.scm")
;; (include "csv-xml/csv-xml.scm")
;; (include "ducttape/ducttape-lib.scm")
;; (include "hostinfo/hostinfo.scm")
;; (include "adjutant.scm")

(declare (uses autoload))
(declare (uses dbi))
(declare (uses pkts))
(declare (uses stml2))
(declare (uses cookie))
(declare (uses csv-xml))
(declare (uses hostinfo))
163
164
165
166
167
168
169
170

171
172
173


174
175
176
177
178
179
180
181
182
183
184
148
149
150
151
152
153
154

155
156


157
158
159
160
161

162
163
164
165
166
167
168







-
+

-
-
+
+



-







;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)
(define setenv set-environment-variable!)
(define unsetenv unset-environment-variable!)

(define *db* #f) ;; this is only for the repl, do not use in general!!!!

;; (include "common_records.scm")
(include "common_records.scm")
;; (include "key_records.scm")
;; (include "db_records.scm")
;; (include "run_records.scm")
(include "db_records.scm")
(include "run_records.scm")
;; (include "test_records.scm")

(include "common.scm")
;; (include "margs.scm")
(include "db.scm")
(include "server.scm")
(include "tests.scm")
(include "genexample.scm")
(include "tdb.scm")
(include "env.scm")
(include "diff-report.scm")
744
745
746
747
748
749
750
751

752
753
754
755
756
757

758
759
760
761
762
763
764
728
729
730
731
732
733
734

735
736
737
738
739
740

741
742
743
744
745
746
747
748







-
+





-
+







     					    (printf "Sending signal/term to ~A\n" pid)
     					    (process-signal pid signal/term))))))
     		       (process:children #f))
     		      (original-exit exit-code)))))
     
     ;; for some switches always print the command to stderr
     ;;
     (if (args:any? "-run" "-runall" "-remove-runs" "-set-state-status" "-kill-runs" "-kill-rerun")
     (if (args:any-defined? "-run" "-runall" "-remove-runs" "-set-state-status" "-kill-runs" "-kill-rerun")
         (debug:print 0 *default-log-port* (string-intersperse (argv) " ")))
     
     ;; some switches imply homehost. Exit here if not on homehost
     ;;
     (let ((homehost-required  (list "-cleanup-db" "-server")))
       (if (apply args:any? homehost-required)
       (if (apply args:any-defined? homehost-required)
           (if (not (common:on-homehost?))
     	  (for-each
     	   (lambda (switch)
     	     (if (args:get-arg switch)
     		 (begin
     		   (debug:print 0 *default-log-port* "ERROR: you must be on the homehost to run with " switch
     				", you can move homehost by removing the .homehost file but this will disrupt any runs in progress.")
1560
1561
1562
1563
1564
1565
1566
1567

1568
1569
1570
1571
1572
1573
1574
1544
1545
1546
1547
1548
1549
1550

1551
1552
1553
1554
1555
1556
1557
1558







-
+







     				     (display (conc "target: " targetstr " "))
     				     (display (conc field-name ": " (db:get-value-by-header run header (conc field-name)) " "))))
     			       runs-spec)
     			      (newline)))))
     		       
     		     (for-each 
     		      (lambda (test)
     		      	(common:debug-handle-exceptions #f
     		      	(handle-exceptions
     			 exn
     			 (begin
     			   (debug:print-error 0 *default-log-port* "Bad data in test record? " test)
     			   (debug:print-error 5 *default-log-port* "exn=" (condition->list exn))
     			   (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
     			   (print-call-chain (current-error-port)))
     			 (let* ((test-id      (if (member "id"           tests-spec)(get-value-by-fieldname test test-field-index "id"          ) #f)) ;; (db:test-get-id         test))
2628
2629
2630
2631
2632
2633
2634
2635
2636


2612
2613
2614
2615
2616
2617
2618


2619
2620







-
-
+
+
              ((1)(exit 1))
              ((2)(exit 2))
              (else (exit 3)))))
     )

)

;; (main)
(print "Got here")
(main)