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
|
;; Copyright 2006-2011, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;; (include "common.scm")
;; (include "megatest-version.scm")
(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses runs))
(declare (uses launch))
(declare (uses server))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(define help (conc "
Megatest, documentation at http://www.kiatoa.com/fossils/megatest
|
|
>
>
|
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
|
;; Copyright 2006-2011, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;; (include "common.scm")
;; (include "megatest-version.scm")
(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 format readline apropos)
(import (prefix sqlite3 sqlite3:))
(import (prefix base64 base64:))
(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses runs))
(declare (uses launch))
(declare (uses server))
(define *db* #f) ;; this is only for the repl, do not use in general!!!!
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(define help (conc "
Megatest, documentation at http://www.kiatoa.com/fossils/megatest
|
︙ | | | ︙ | |
91
92
93
94
95
96
97
98
99
100
101
102
103
104
|
-update-meta : update the tests metadata for all tests
-env2file fname : write the environment to fname.csh and fname.sh
-setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are
overwritten by values set in config files.
-archive : archive tests, use -target, :runname, -itempatt and -testpatt
-server -|hostname : start the server (reduces contention on megatest.db), use
- to automatically figure out hostname
Spreadsheet generation
-extract-ods fname.ods : extract an open document spreadsheet from the database
-pathmod path : insert path, i.e. path/runame/itempath/logfile.html
will clear the field if no rundir/testname/itempath/logfile
if it contains forward slashes the path will be converted
to windows style
|
>
|
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
|
-update-meta : update the tests metadata for all tests
-env2file fname : write the environment to fname.csh and fname.sh
-setvars VAR1=val1,VAR2=val2 : Add environment variables to a run NB// these are
overwritten by values set in config files.
-archive : archive tests, use -target, :runname, -itempatt and -testpatt
-server -|hostname : start the server (reduces contention on megatest.db), use
- to automatically figure out hostname
-repl : start a repl (useful for extending megatest)
Spreadsheet generation
-extract-ods fname.ods : extract an open document spreadsheet from the database
-pathmod path : insert path, i.e. path/runame/itempath/logfile.html
will clear the field if no rundir/testname/itempath/logfile
if it contains forward slashes the path will be converted
to windows style
|
︙ | | | ︙ | |
168
169
170
171
172
173
174
175
176
177
178
179
180
181
|
"-test-status"
"-set-values"
"-load-test-data"
"-summarize-items"
"-gui"
;; misc
"-archive"
;; queries
"-test-paths" ;; get path(s) to a test, ordered by youngest first
"-runall" ;; run all tests
"-remove-runs"
"-keepgoing"
"-usequeue"
|
>
|
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
|
"-test-status"
"-set-values"
"-load-test-data"
"-summarize-items"
"-gui"
;; misc
"-archive"
"-repl"
;; queries
"-test-paths" ;; get path(s) to a test, ordered by youngest first
"-runall" ;; run all tests
"-remove-runs"
"-keepgoing"
"-usequeue"
|
︙ | | | ︙ | |
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
|
(if (args:get-arg "-list-runs")
(let* ((db (begin
(setup-for-run)
(open-db)))
(runpatt (args:get-arg "-list-runs"))
(testpatt (args:get-arg "-testpatt"))
(itempatt (args:get-arg "-itempatt"))
(runsdat (db:get-runs db runpatt #f #f '()))
(runs (db:get-rows runsdat))
(header (db:get-header runsdat))
(keys (db-get-keys db))
(keynames (map key:get-fieldname keys)))
;; Each run
(for-each
(lambda (run)
(debug:print 2 "Run: "
(string-intersperse (map (lambda (x)
(db:get-value-by-header run header x))
|
|
|
|
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
|
(if (args:get-arg "-list-runs")
(let* ((db (begin
(setup-for-run)
(open-db)))
(runpatt (args:get-arg "-list-runs"))
(testpatt (args:get-arg "-testpatt"))
(itempatt (args:get-arg "-itempatt"))
(runsdat (rdb:get-runs db runpatt #f #f '()))
(runs (db:get-rows runsdat))
(header (db:get-header runsdat))
(keys (rdb:get-keys db))
(keynames (map key:get-fieldname keys)))
;; Each run
(for-each
(lambda (run)
(debug:print 2 "Run: "
(string-intersperse (map (lambda (x)
(db:get-value-by-header run header x))
|
︙ | | | ︙ | |
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
|
(if (args:get-arg "-server")
(let* ((toppath (setup-for-run))
(db (if toppath (open-db) #f)))
(if db
(server:start db (args:get-arg "-server"))
(debug:print 0 "ERROR: Failed to setup for megatest"))))
;;;======================================================================
;; Rollup into a run
;;======================================================================
(if (args:get-arg "-rollup")
(general-run-call
"-rollup"
"rollup tests"
(lambda (db keys keynames keyvallst)
(runs:rollup-run db
keys
(keys->alist keys "na")
(args:get-arg ":runname")
user))))
;;======================================================================
|
|
|
|
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
|
(if (args:get-arg "-server")
(let* ((toppath (setup-for-run))
(db (if toppath (open-db) #f)))
(if db
(server:start db (args:get-arg "-server"))
(debug:print 0 "ERROR: Failed to setup for megatest"))))
;;======================================================================
;; Rollup into a run
;;======================================================================
(if (args:get-arg "-rollup")
(general-run-call
"-rollup"
"rollup tests"
(lambda (db target runname keys keynames keyvallst)
(runs:rollup-run db
keys
(keys->alist keys "na")
(args:get-arg ":runname")
user))))
;;======================================================================
|
︙ | | | ︙ | |
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
|
(exit 1)))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, giving up on -test-paths, exiting")
(exit 1)))
(set! db (open-db))
(let* ((itempatt (args:get-arg "-itempatt"))
(keys (db-get-keys db))
(keynames (map key:get-fieldname keys))
(paths (db:test-get-paths-matching db keynames target)))
(set! *didsomething* #t)
(for-each (lambda (path)
(print path))
paths)))
;; else do a general-run-call
|
|
|
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
|
(exit 1)))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, giving up on -test-paths, exiting")
(exit 1)))
(set! db (open-db))
(let* ((itempatt (args:get-arg "-itempatt"))
(keys (rdb:get-keys db))
(keynames (map key:get-fieldname keys))
(paths (db:test-get-paths-matching db keynames target)))
(set! *didsomething* #t)
(for-each (lambda (path)
(print path))
paths)))
;; else do a general-run-call
|
︙ | | | ︙ | |
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
|
(exit 1)))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, giving up on -archive, exiting")
(exit 1)))
(set! db (open-db))
(let* ((itempatt (args:get-arg "-itempatt"))
(keys (db-get-keys db))
(keynames (map key:get-fieldname keys))
(paths (db:test-get-paths-matching db keynames target)))
(set! *didsomething* #t)
(for-each (lambda (path)
(print path))
paths)))
;; else do a general-run-call
|
|
|
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
|
(exit 1)))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, giving up on -archive, exiting")
(exit 1)))
(set! db (open-db))
(let* ((itempatt (args:get-arg "-itempatt"))
(keys (rdb:get-keys db))
(keynames (map key:get-fieldname keys))
(paths (db:test-get-paths-matching db keynames target)))
(set! *didsomething* #t)
(for-each (lambda (path)
(print path))
paths)))
;; else do a general-run-call
|
︙ | | | ︙ | |
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
|
(let ((db #f)
(keys #f))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(set! db (open-db))
(set! keys (db-get-keys db))
(debug:print 1 "Keys: " (string-intersperse (map key:get-fieldname keys) ", "))
(sqlite3:finalize! db)
(set! *didsomething* #t)))
(if (args:get-arg "-gui")
(begin
(debug:print 0 "Look at the dashboard for now")
|
|
|
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
|
(let ((db #f)
(keys #f))
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(set! db (open-db))
(set! keys (rdb:get-keys db))
(debug:print 1 "Keys: " (string-intersperse (map key:get-fieldname keys) ", "))
(sqlite3:finalize! db)
(set! *didsomething* #t)))
(if (args:get-arg "-gui")
(begin
(debug:print 0 "Look at the dashboard for now")
|
︙ | | | ︙ | |
722
723
724
725
726
727
728
729
730
731
732
733
734
735
|
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
;; now can find our db
(set! db (open-db))
(runs:update-all-test_meta db)
(sqlite3:finalize! db)
(set! *didsomething* #t)))
(if (not *didsomething*)
(debug:print 0 help))
(if (not (eq? *globalexitstatus* 0))
(if (or (args:get-arg "-runtests")(args:get-arg "-runall"))
(begin
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
|
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
;; now can find our db
(set! db (open-db))
(runs:update-all-test_meta db)
(sqlite3:finalize! db)
(set! *didsomething* #t)))
;;======================================================================
;; Start a repl
;;======================================================================
(if (args:get-arg "-repl")
(let* ((toppath (setup-for-run))
(db (if toppath (open-db) #f)))
(if db
(begin
(set! *db* db)
(import readline)
(import apropos)
(gnu-history-install-file-manager
(string-append
(or (get-environment-variable "HOME") ".") "/.megatest_history"))
(current-input-port (make-gnu-readline-port "megatest> "))
(repl)))))
;;======================================================================
;; Exit and clean up
;;======================================================================
(if (not *didsomething*)
(debug:print 0 help))
(if (not (eq? *globalexitstatus* 0))
(if (or (args:get-arg "-runtests")(args:get-arg "-runall"))
(begin
|
︙ | | | ︙ | |