1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
|
;; Copyright 2006-2012, 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 readline apropos json http-client directory-utils rpc ;; (srfi 18) extras)
http-client srfi-18 extras format) ;; zmq extras)
;; Added for csv stuff - will be removed
;;
(use sparse-vectors)
|
>
>
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
|
;; Copyright 2006-2012, 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")
(define (toplevel-command . a) #f)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 readline apropos json http-client directory-utils rpc ;; (srfi 18) extras)
http-client srfi-18 extras format) ;; zmq extras)
;; Added for csv stuff - will be removed
;;
(use sparse-vectors)
|
︙ | | | ︙ | |
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
|
(testpatt (if (args:get-arg "-testpatt")
(args:get-arg "-testpatt")
"%"))
(keys (db:get-keys dbstruct))
;; (runsdat (db:get-runs dbstruct runpatt #f #f '()))
(runsdat (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target)
#f #f))
;; (cdb:remote-run db:get-runs #f runpatt #f #f '()))
(runs (db:get-rows runsdat))
(header (db:get-header runsdat))
(db-targets (args:get-arg "-list-db-targets"))
(seen (make-hash-table))
(dmode (let ((d (args:get-arg "-dumpmode")))
(if d (string->symbol d) #f)))
(data (make-hash-table)))
|
<
|
888
889
890
891
892
893
894
895
896
897
898
899
900
901
|
(testpatt (if (args:get-arg "-testpatt")
(args:get-arg "-testpatt")
"%"))
(keys (db:get-keys dbstruct))
;; (runsdat (db:get-runs dbstruct runpatt #f #f '()))
(runsdat (db:get-runs-by-patt dbstruct keys (or runpatt "%") (common:args-get-target)
#f #f))
(runs (db:get-rows runsdat))
(header (db:get-header runsdat))
(db-targets (args:get-arg "-list-db-targets"))
(seen (make-hash-table))
(dmode (let ((d (args:get-arg "-dumpmode")))
(if d (string->symbol d) #f)))
(data (make-hash-table)))
|
︙ | | | ︙ | |
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
|
(if (args:get-arg "-runstep")(debug:print-info 1 "Running -runstep, first change to directory " work-area))
(change-directory work-area)
;; can setup as client for server mode now
;; (client:setup)
(if (args:get-arg "-load-test-data")
;; has sub commands that are rdb:
;; DO NOT put this one into either cdb:remote-run or open-run-close
(tdb:load-test-data run-id test-id))
(if (args:get-arg "-setlog")
(let ((logfname (args:get-arg "-setlog")))
(rmt:test-set-log! run-id test-id logfname)))
(if (args:get-arg "-set-toplog")
;; DO NOT run remote
(tests:test-set-toplog! run-id test-name (args:get-arg "-set-toplog")))
|
|
|
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
|
(if (args:get-arg "-runstep")(debug:print-info 1 "Running -runstep, first change to directory " work-area))
(change-directory work-area)
;; can setup as client for server mode now
;; (client:setup)
(if (args:get-arg "-load-test-data")
;; has sub commands that are rdb:
;; DO NOT put this one into either rmt: or open-run-close
(tdb:load-test-data run-id test-id))
(if (args:get-arg "-setlog")
(let ((logfname (args:get-arg "-setlog")))
(rmt:test-set-log! run-id test-id logfname)))
(if (args:get-arg "-set-toplog")
;; DO NOT run remote
(tests:test-set-toplog! run-id test-name (args:get-arg "-set-toplog")))
|
︙ | | | ︙ | |
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
|
(args:get-arg "-show-keys"))
(let ((db #f)
(keys #f))
(if (not (launch:setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(set! keys (cdb:remote-run db:get-keys db))
(debug:print 1 "Keys: " (string-intersperse keys ", "))
(if (sqlite3:database? db)(sqlite3:finalize! db))
(set! *didsomething* #t)))
(if (args:get-arg "-gui")
(begin
(debug:print 0 "Look at the dashboard for now")
|
|
|
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
|
(args:get-arg "-show-keys"))
(let ((db #f)
(keys #f))
(if (not (launch:setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
(exit 1)))
(set! keys (rmt:get-keys)) ;; db))
(debug:print 1 "Keys: " (string-intersperse keys ", "))
(if (sqlite3:database? db)(sqlite3:finalize! db))
(set! *didsomething* #t)))
(if (args:get-arg "-gui")
(begin
(debug:print 0 "Look at the dashboard for now")
|
︙ | | | ︙ | |
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
|
(set! *didsomething* #t)))
;;======================================================================
;; Start a repl
;;======================================================================
;; fakeout readline
(define (toplevel-command . a) #f)
(if (or (args:get-arg "-repl")
(args:get-arg "-load"))
(let* ((toppath (launch:setup-for-run))
(dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)))
(if dbstruct
(begin
(set! *db* dbstruct)
(set! *client-non-blocking-mode* #t)
(import extras) ;; might not be needed
;; (import csi)
(import readline)
(import apropos)
;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
(gnu-history-install-file-manager
(string-append
(or (get-environment-variable "HOME") ".") "/.megatest_history"))
(current-input-port (make-gnu-readline-port "megatest> "))
(if (args:get-arg "-repl")
(repl)
(load (args:get-arg "-load")))
|
<
>
|
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
|
(set! *didsomething* #t)))
;;======================================================================
;; Start a repl
;;======================================================================
;; fakeout readline
(if (or (args:get-arg "-repl")
(args:get-arg "-load"))
(let* ((toppath (launch:setup-for-run))
(dbstruct (if toppath (make-dbr:dbstruct path: toppath local: #t) #f)))
(if dbstruct
(begin
(set! *db* dbstruct)
(set! *client-non-blocking-mode* #t)
(import extras) ;; might not be needed
;; (import csi)
(import readline)
(import apropos)
;; (import (prefix sqlite3 sqlite3:)) ;; doesn't work ...
(include "readline-fix.scm")
(gnu-history-install-file-manager
(string-append
(or (get-environment-variable "HOME") ".") "/.megatest_history"))
(current-input-port (make-gnu-readline-port "megatest> "))
(if (args:get-arg "-repl")
(repl)
(load (args:get-arg "-load")))
|
︙ | | | ︙ | |