Modified Makefile
from [7db8b5bb38]
to [8f79ba7a0c].
︙ | | |
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
|
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
|
-
+
+
+
+
+
+
+
+
+
+
|
subrun.scm portlogger.scm archive.scm env.scm \
diff-report.scm pgdb.scm
# cgisetup/models/pgdb.scm
# module source files
MSRCFILES = dbmod.scm dbfile.scm debugprint.scm mtargs.scm commonmod.scm \
ducttape-lib.scm pkts.scm dbi.scm autoload.scm
ducttape-lib.scm pkts.scm dbi.scm autoload.scm stml2.scm
# ftail.scm rmtmod.scm commonmod.scm removed
# MSRCFILES = ducttape-lib.scm pkts.scm stml2.scm cookie.scm mutils.scm \
# mtargs.scm commonmod.scm dbmod.scm adjutant.scm ulex.scm \
# rmtmod.scm apimod.scm
GUISRCF = dashboard-context-menu.scm dashboard-tests.scm \
dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm \
vg.scm
OFILES = $(SRCFILES:%.scm=%.o)
GOFILES = $(GUISRCF:%.scm=%.o)
TMPMODS = $(SRCFILES:%.scm=tmpmods/%.scm)
OTMPMODS = $(SRCFILES:%.scm=tmpmods/%.o)
tmpmods/%.scm : %.scm utils/makemodulewrap.sh
./utils/makemodulewrap.sh $*
tmpmods/%.o : tmpmods/%.scm
csc $(CSCOPTS) -J -c $< -o tmpmods/$*.o
MOFILES = $(addprefix mofiles/,$(MSRCFILES:%.scm=%.o))
# compiled import files
MOIMPFILES = $(MSRCFILES:%.scm=%.import.o)
%.import.o : %.import.scm
csc $(CSCOPTS) -unit $*.import -c $*.import.scm -o $*.import.o
|
︙ | | |
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
|
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
|
-
+
|
megatest-fossil-hash.scm : $(SRCFILES) megatest.scm *_records.scm
echo "(define megatest-fossil-hash \"$(MTESTHASH)\")" > megatest-fossil-hash.new
if ! diff -q megatest-fossil-hash.new megatest-fossil-hash.scm ; then echo copying .new to .scm;cp -f megatest-fossil-hash.new megatest-fossil-hash.scm;fi
$(OFILES) $(GOFILES) : common_records.scm
%.o : %.scm $(MOFILES)
%.o : %.scm $(MOFILES) tmpmods/%.o
csc $(CSCOPTS) -c $< $(MOFILES)
$(PREFIX)/bin/.$(ARCHSTR)/mtest : mtest utils/mk_wrapper
@echo Installing to PREFIX=$(PREFIX)
$(INSTALL) mtest $(PREFIX)/bin/.$(ARCHSTR)/mtest
utils/mk_wrapper $(PREFIX) mtest $(PREFIX)/bin/megatest
chmod a+x $(PREFIX)/bin/megatest
|
︙ | | |
Modified api.scm
from [736048365d]
to [c8a32239fd].
︙ | | |
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
-
+
+
+
+
+
+
|
;; 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/>.
;;
;;======================================================================
(use srfi-69 posix)
(import srfi-69
;; posix
chicken.process-context.posix
chicken.time
chicken.string
)
(declare (unit api))
(declare (uses rmt))
(declare (uses db))
(declare (uses dbmod))
(declare (uses dbfile))
(declare (uses tasks))
|
︙ | | |
Modified archive.scm
from [9231707c41]
to [9715fc696d].
︙ | | |
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
|
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
|
+
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
(import
(prefix sqlite3 sqlite3:) srfi-1
;; posix
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18)
regex regex-case srfi-69 format md5 message-digest srfi-18
srfi-13
chicken.file
chicken.io
chicken.pathname
chicken.port
chicken.pretty-print
chicken.process
chicken.string
chicken.time
chicken.time.posix
chicken.condition
)
(declare (unit archive))
(declare (uses db))
(declare (uses common))
(include "common_records.scm")
(include "db_records.scm")
|
︙ | | |
Modified cgisetup/models/pgdb.scm
from [e3378946ce]
to [20db61298c].
︙ | | |
16
17
18
19
20
21
22
23
24
25
26
27
28
29
|
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
|
+
+
+
+
+
+
+
+
+
+
|
;; 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 pgdb))
(import
chicken.sort
chicken.string
srfi-1
srfi-69
chicken.condition
typed-records
)
;; (declare (uses configf))
;;
;; ;; I don't know how to mix compilation units and modules, so no module here.
;; ;;
;; ;; (module pgdb
;; ;; (
;; ;; open-pgdb
|
︙ | | |
Modified client.scm
from [3f204dd646]
to [6ac287a710].
︙ | | |
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
|
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
|
+
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
;; C L I E N T S
;;======================================================================
(import srfi-18
(use srfi-18 extras tcp s11n srfi-1 posix regex srfi-69 hostinfo md5
message-digest matchable spiffy uri-common intarweb http-client
spiffy-request-vars uri-common intarweb directory-utils)
;; extras tcp s11n
srfi-1
;; posix
regex srfi-69
;; hostinfo
md5
message-digest matchable spiffy uri-common intarweb http-client
spiffy-request-vars uri-common intarweb
;; directory-utils)
chicken.port
chicken.pretty-print
chicken.process-context.posix
chicken.string
chicken.time
system-information
)
(declare (unit client))
(declare (uses common))
(declare (uses db))
(declare (uses tasks)) ;; tasks are where stuff is maintained about what is running.
|
︙ | | |
Modified codescanlib.scm
from [6e625610ce]
to [15d1645439].
︙ | | |
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
|
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
;; gotta compile with csc, doesn't work with csi -s for whatever reason
(use srfi-69)
(use matchable)
(use utils)
(use ports)
(use extras)
(use srfi-1)
(use posix)
(use srfi-12)
(import srfi-69)
(import matchable)
(import utils)
(import ports)
(import extras)
(import srfi-1)
(import posix)
(import srfi-12)
;; turn scheme file to a list of sexps, sexps of interest will be in the form of (define (<procname> <args>) <body> )
(define (load-scm-file scm-file)
;;(print "load "scm-file)
(handle-exceptions
exn
'()
|
︙ | | |
Modified common.scm
from [511916cc75]
to [613fa01aef].
︙ | | |
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
|
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
|
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
+
|
;; 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 common))
(declare (uses commonmod))
(declare (uses pkts))
(declare (uses dbi))
(import
srfi-1
srfi-69
;; data-structures posix
(use srfi-1 data-structures posix regex-case (prefix base64 base64:)
format dot-locking csv-xml z3 udp ;; sql-de-lite
hostinfo md5 message-digest typed-records directory-utils stack
matchable regex posix (srfi 18) extras ;; tcp
(prefix nanomsg nmsg:)
(prefix sqlite3 sqlite3:)
pkts (prefix dbi dbi:)
)
regex-case (prefix base64 base64:)
chicken.condition
chicken.file
chicken.file.posix
chicken.format
chicken.io
chicken.pathname
chicken.port
chicken.pretty-print
chicken.process
chicken.process-context
chicken.process-context.posix
chicken.process.signal
chicken.string
chicken.sort
chicken.time
chicken.time.posix
;; dot-locking
;; csv-xml
z3
;; udp ;; sql-de-lite
;; hostinfo
md5
message-digest typed-records
;; directory-utils
sparse-vectors
stack
matchable regex
;; posix
(srfi 18)
srfi-13
system-information
;; extras ;; tcp
(prefix nanomsg nmsg:)
(prefix sqlite3 sqlite3:)
pkts
(prefix dbi dbi:)
)
;; (import posix-extras pathname-expand files)
(declare (unit common))
(declare (uses commonmod))
(import commonmod)
(include "common_records.scm")
(define setenv set-environment-variable!)
;; (require-library margs)
;; (include "margs.scm")
;; (define old-exit exit)
;;
;; (define (exit . code)
;; (if (null? code)
|
︙ | | |
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
|
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
|
-
-
-
+
|
(define *launch-setup-mutex* (make-mutex)) ;; need to be able to call launch:setup often so mutex it and re-call the real deal only if *toppath* not set
(define *homehost-mutex* (make-mutex))
;; Miscellaneous
(define *triggers-mutex* (make-mutex)) ;; block overlapping processing of triggers
(define *numcpus-cache* (make-hash-table))
(use posix-extras pathname-expand files)
;; this plugs a hole in posix-extras in recent chicken versions > 4.9)
#;(let-values (( (chicken-release-number chicken-major-version)
(apply values
(map string->number
(take
(string-split (chicken-version) ".")
2)))))
(let ((resolve-pathname-broken?
(or (> chicken-release-number 4)
(and (eq? 4 chicken-release-number) (> chicken-major-version 9)))))
(if resolve-pathname-broken?
(define ##sys#expand-home-path pathname-expand))))
(define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) ))
;; (define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) ))
(define (common:get-this-exe-fullpath #!key (argv (argv)))
(let* ((this-script
(cond
((and (> (length argv) 2)
(string-match "^(.*/csi|csi)$" (car argv))
(string-match "^-(s|ss|sx|script)$" (cadr argv)))
|
︙ | | |
Modified common_records.scm
from [80f9e14f2d]
to [f0871746f6].
︙ | | |
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
|
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
|
-
+
|
;; 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/>.
;;
;;======================================================================
;; (use trace)
;; (import trace)
(include "altdb.scm")
;; Some of these routines use:
;;
;; http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html
;;
|
︙ | | |
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
|
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
|
-
+
|
((pair? arg) (cons (BBpp_ (car arg)) (BBpp_ (cdr arg))))
(else (BBpp_custom_converter arg))))
;; Brandon's pretty printer. It expands hashes and custom types in addition to regular pp
(define (BBpp arg)
(pp (BBpp_ arg)))
;(use define-macro)
;(import define-macro)
(define-syntax inspect
(syntax-rules ()
[(_ x)
;; (with-output-to-port (current-error-port)
(printf "~a is: ~a\n" 'x (with-output-to-string (lambda () (BBpp x))))
;; )
]
|
︙ | | |
Modified commonmod.scm
from [7b81cda74c]
to [560de8386a].
︙ | | |
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
-
+
|
;; 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 commonmod))
(use srfi-69)
(import srfi-69)
(module commonmod
*
(import
scheme
chicken.base
|
︙ | | |
Modified configf.scm
from [b768bf346e]
to [55b026c22e].
︙ | | |
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
|
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
|
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;;======================================================================
;;======================================================================
;; Config file handling
;;======================================================================
(use regex regex-case matchable) ;; directory-utils)
(declare (unit configf))
(declare (uses process))
(declare (uses env))
(declare (uses keys))
(import
regex regex-case matchable
chicken.condition
chicken.file
chicken.io
chicken.pathname
chicken.port
chicken.pretty-print
chicken.process
chicken.process-context
chicken.sort
chicken.string
chicken.time
srfi-1
srfi-13
srfi-69
)
(include "common_records.scm")
;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
(if toppath
(let ((cfname (conc toppath "/" configname)))
|
︙ | | |
Modified dashboard-context-menu.scm
from [48947370a7]
to [ec3b16f7e2].
︙ | | |
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
|
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
|
-
+
-
+
+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;;======================================================================
;;======================================================================
;; implementation of context menu that pops up on
;; right click on test cell in Runs & Runs Summary Tabs
;;======================================================================
(use format fmt)
(import format fmt)
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)
(import canvas-draw)
(import
srfi-1
;; posix
(use srfi-1 posix regex regex-case srfi-69)
(use (prefix sqlite3 sqlite3:))
regex regex-case srfi-69
chicken.pathname
chicken.port
chicken.pretty-print
chicken.process
chicken.string
chicken.time
chicken.condition
chicken.process-context
)
(import (prefix sqlite3 sqlite3:))
(declare (unit dashboard-context-menu))
(declare (uses common))
(declare (uses db))
(declare (uses gutils))
(declare (uses rmt))
(declare (uses ezsteps))
|
︙ | | |
Modified dashboard-guimonitor.scm
from [9920d4908c]
to [d74c0cf4ec].
︙ | | |
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
|
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
|
-
+
-
+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
|
;;
;;======================================================================
;;======================================================================
;; Test info panel
;;======================================================================
(use format)
(import format)
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)
(import canvas-draw)
(import sqlite3 srfi-1
;; posix
(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))
regex regex-case srfi-69)
(import
(prefix sqlite3 sqlite3:)
chicken.file.posix
chicken.port
chicken.pretty-print
chicken.string
chicken.time
)
(declare (unit dashboard-guimonitor))
(declare (uses common))
(declare (uses keys))
(declare (uses db))
(declare (uses tasks))
(include "common_records.scm")
|
︙ | | |
Modified dashboard-tests.scm
from [237d160a6c]
to [922201ada9].
︙ | | |
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
|
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
|
-
+
-
+
+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;;======================================================================
;;======================================================================
;; Test info panel
;;======================================================================
(use format fmt)
(import format fmt)
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)
(import canvas-draw)
(import
srfi-1
;; posix
(use srfi-1 posix regex regex-case srfi-69)
(use (prefix sqlite3 sqlite3:))
regex regex-case srfi-69
chicken.file
chicken.file.posix
chicken.port
chicken.pretty-print
chicken.string
chicken.time
srfi-18
chicken.condition
chicken.process-context
)
(import (prefix sqlite3 sqlite3:))
(declare (unit dashboard-tests))
(declare (uses common))
(declare (uses db))
(declare (uses gutils))
(declare (uses rmt))
(declare (uses ezsteps))
|
︙ | | |
Modified dashboard.scm
from [8af2600b2e]
to [f75d6c4a3e].
︙ | | |
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
|
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
|
-
+
-
+
-
-
+
+
+
+
+
|
;; 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/>.
;;
;;======================================================================
(use format)
(import format)
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)
(import canvas-draw)
(import canvas-draw-iup)
(use ducttape-lib)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct
(import ducttape-lib)
(import
sqlite3 srfi-1
;; posix
regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct
(import (prefix sqlite3 sqlite3:))
(import dbfile)
(declare (uses common))
(declare (uses margs))
(declare (uses keys))
(declare (uses items))
|
︙ | | |
Modified datashare.scm
from [b486cc13b7]
to [09095ffa44].
︙ | | |
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
|
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
|
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
-
+
-
+
-
+
|
;; 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/>.
;; ==> (module datashare
;; ==> (use ssax)
;; ==> (use sxml-serializer)
;; ==> (use sxml-modifications)
;; ==> (use regex)
;; ==> (use srfi-69)
;; ==> (use regex-case)
;; ==> (use posix)
;; ==> (use json)
;; ==> (use csv)
;; ==> (use srfi-18)
;; ==> (use format)
;; ==> (import ssax)
;; ==> (import sxml-serializer)
;; ==> (import sxml-modifications)
;; ==> (import regex)
;; ==> (import srfi-69)
;; ==> (import regex-case)
;; ==> (import posix)
;; ==> (import json)
;; ==> (import csv)
;; ==> (import srfi-18)
;; ==> (import format)
;; ==>
;; ==> (use (prefix iup iup:))
;; ==> (import (prefix iup iup:))
;; ==> (import (prefix ini-file ini:))
;; ==>
;; ==> (use canvas-draw)
;; ==> (import canvas-draw)
;; ==> (import canvas-draw-iup)
;; ==>
;; ==> (use sqlite3 srfi-1 posix regex regex-case srfi-69)
;; ==> (import sqlite3 srfi-1 posix regex regex-case srfi-69)
;; ==> (import (prefix sqlite3 sqlite3:))
;; ==>
;; ==> (declare (uses configf))
;; ==> (declare (uses tree))
;; ==> (declare (uses margs))
;; ==> ;; (declare (uses dcommon))
;; ==> ;; (declare (uses launch))
|
︙ | | |
Modified db.scm
from [8c84d35a2c]
to [d664b8a1ca].
︙ | | |
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
|
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
|
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;;======================================================================
;; Database access
;;======================================================================
;; dbstruct vector containing all the relevant dbs like main.db, megatest.db, run.db etc
(import
(use (srfi 18)
extras
tcp
stack
(prefix sqlite3 sqlite3:)
srfi-1
posix
regex
regex-case
srfi-69
csv-xml
s11n
md5
message-digest
(prefix base64 base64:)
format
dot-locking
z3
typed-records
matchable
files)
(srfi 18)
;; extras
;; tcp
stack
(prefix sqlite3 sqlite3:)
srfi-1
;; posix
regex
regex-case
srfi-69
;; csv-xml
s11n
md5
message-digest
(prefix base64 base64:)
;; format
;; dot-locking
z3
typed-records
matchable
;; files
srfi-13
chicken.condition
chicken.file
chicken.file.posix
chicken.format
chicken.io
chicken.pathname
chicken.port
chicken.pretty-print
chicken.process
chicken.process-context
chicken.process-context.posix
chicken.sort
chicken.string
chicken.time
chicken.time.posix
)
(declare (unit db))
(declare (uses common))
(declare (uses dbmod))
;; (declare (uses debugprint))
(declare (uses dbfile))
(declare (uses keys))
|
︙ | | |
Modified dcommon.scm
from [dbcf309f44]
to [0e61d04cc8].
︙ | | |
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
|
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
|
-
+
-
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;; 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/>.
;;
;;======================================================================
(use format)
(import format)
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)
(import canvas-draw)
(import canvas-draw-iup)
(use regex typed-records matchable)
(import regex typed-records matchable
chicken.condition
chicken.file
chicken.file.posix
chicken.port
chicken.pretty-print
chicken.process
chicken.process-context
chicken.process-context.posix
chicken.sort
chicken.string
chicken.time
srfi-1
srfi-18
srfi-69
)
(declare (unit dcommon))
(declare (uses gutils))
(declare (uses db))
;; (declare (uses synchash))
|
︙ | | |
Modified diff-report.scm
from [6d3c4f6f16]
to [3d883d322e].
︙ | | |
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
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
|
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;;
(declare (unit diff-report))
(declare (uses common))
(declare (uses rmt))
(declare (uses ducttape-lib))
(include "common_records.scm")
(import
matchable
fmt
ducttape-lib)
ducttape-lib
chicken.port
chicken.pretty-print
chicken.sort
chicken.string
chicken.time
chicken.time.posix
srfi-1
srfi-69
srfi-13
)
(include "common_records.scm")
(define css "")
(define (diff:tests-mindat->hash tests-mindat)
(let* ((res (make-hash-table)))
(for-each
(lambda (item)
|
︙ | | |
Modified env.scm
from [028e47144f]
to [cf5b8da19c].
︙ | | |
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
|
+
-
+
+
+
+
+
+
|
;; 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 env))
(import
(use sql-de-lite) ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)
sql-de-lite ;; srfi-1 posix regex regex-case srfi-69 srfi-18 call-with-environment-variables)
chicken.string
srfi-1
srfi-69
chicken.process-context
)
(define (env:open-db fname)
(let* ((db-exists (common:file-exists? fname))
(db (open-database fname)))
(if (not db-exists)
(begin
(exec (sql db "CREATE TABLE envvars (
|
︙ | | |
Modified ezsteps.scm
from [aab87817a5]
to [b4b9cbb9eb].
︙ | | |
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
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
|
+
+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
(import
srfi-1
;; posix regex srfi-69
;; directory-utils
(use srfi-1 posix regex srfi-69 directory-utils call-with-environment-variables posix-extras
z3 csv typed-records pathname-expand matchable)
;; call-with-environment-variables posix-extras
z3
;; csv
typed-records pathname-expand matchable
chicken.file
chicken.port
chicken.pretty-print
chicken.process
chicken.string
chicken.time
srfi-18
srfi-69
chicken.process-context
regex
)
(declare (unit ezsteps))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))
|
︙ | | |
Modified gen-data-for-graph.scm
from [253156d2fd]
to [66449aaee2].
︙ | | |
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
|
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
|
-
+
|
;; 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/>.
;;
(use foof-loop sql-de-lite posix)
(import foof-loop sql-de-lite posix)
(define beginning-2016 1451636435.0)
(define now (current-seconds))
(define one-year-ago (- now (* 365 24 60 60)))
(define db (open-database "example.db"))
|
︙ | | |
Modified genexample.scm
from [c6a2ab2853]
to [c849d0adaa].
︙ | | |
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
|
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
|
+
-
+
+
+
+
+
+
+
+
+
+
+
+
|
;;
;; 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 genexample))
(import
(use posix regex matchable)
regex matchable
chicken.file
chicken.file.posix
chicken.io
chicken.process
chicken.process-context
chicken.process-context.posix
chicken.string
srfi-1
srfi-69
srfi-13
)
(include "db_records.scm")
(define genexample:example-logpro
#<<EOF
;; You should have at least one expect:required. This ensures that your process ran
;; comment out the line below and replace "put pattern here" with a pattern that will
|
︙ | | |
Modified gutils.scm
from [455c3c7ee1]
to [6910cb937c].
︙ | | |
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
|
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
|
-
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
;;======================================================================
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)
(import canvas-draw)
(import
(use srfi-1 regex regex-case srfi-69)
srfi-1 regex regex-case srfi-69
chicken.string
chicken.condition
chicken.file
chicken.file.posix
chicken.port
chicken.pretty-print
chicken.process
chicken.process-context
chicken.process-context.posix
chicken.sort
chicken.string
chicken.time
srfi-1
srfi-18
srfi-69
)
(declare (unit gutils))
;; NOTE: These functions will move to iuputils
(define (gutils:colors-similar? color1 color2)
(let* ((c1 (map string->number (string-split color1)))
(c2 (map string->number (string-split color2)))
|
︙ | | |
Modified http-transport.scm
from [9f49aa94f0]
to [a08be1ce79].
︙ | | |
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
|
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
|
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
srfi-1
;; posix
regex regex-case srfi-69
;; hostinfo
md5 message-digest
;;posix-extras
spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing)
spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing
chicken.condition
chicken.file
chicken.pathname
chicken.port
chicken.pretty-print
chicken.process
chicken.process-context
chicken.process-context.posix
chicken.string
chicken.time
chicken.time.posix
system-information
srfi-13
chicken.io
)
;; Configurations for server
(tcp-buffer-size 2048)
(max-connections 2048)
(declare (unit http-transport))
|
︙ | | |
50
51
52
53
54
55
56
57
58
59
60
61
62
63
|
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
|
+
+
+
+
|
(include "common_records.scm")
(include "db_records.scm")
(include "js-path.scm")
(import dbfile commonmod)
(require-library stml)
(define setenv set-environment-variable!)
(define getenv get-environment-variable)
(define (http-transport:make-server-url hostport)
(if (not hostport)
#f
(conc "http://" (car hostport) ":" (cadr hostport))))
(define *server-loop-heart-beat* (current-seconds))
|
︙ | | |
Modified index-tree.scm
from [10c620fbfc]
to [1cd29734d8].
︙ | | |
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
|
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
|
-
+
|
;;
;;======================================================================
;;======================================================================
;; Tests
;;======================================================================
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
(import sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
(import (prefix sqlite3 sqlite3:))
(declare (unit tests))
(declare (uses lock-queue))
(declare (uses db))
(declare (uses common))
(declare (uses items))
|
︙ | | |
Modified items.scm
from [16328a4b96]
to [1c8e27c314].
︙ | | |
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
|
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
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;; (define itemdat '((ripeness "green ripe overripe")
;; (temperature "cool medium hot")
;; (season "summer winter fall spring")))
(declare (unit items))
(declare (uses common))
(import
chicken.file
chicken.io
chicken.port
chicken.pretty-print
chicken.string
chicken.time
chicken.process-context
srfi-1
srfi-69)
(include "common_records.scm")
(define setenv set-environment-variable!)
(define getenv get-environment-variable)
;; Puts out all combinations
(define (process-itemlist hierdepth curritemkey itemlist)
(let ((res '()))
(if (not hierdepth)
(set! hierdepth (length itemlist)))
(let loop ((hed (car itemlist))
|
︙ | | |
Modified keys.scm
from [9fa2c0cfa5]
to [f4f75e41b3].
︙ | | |
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
|
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
|
-
-
+
+
+
+
+
+
+
+
+
|
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;
;;======================================================================
;; Run keys, these are used to hierarchially organise tests and run areas
;;======================================================================
(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))
(import sqlite3 srfi-1
;; posix
regex regex-case srfi-69 (prefix sqlite3 sqlite3:)
chicken.port
chicken.pretty-print
chicken.string
chicken.time
srfi-13
)
(declare (unit keys))
(declare (uses common))
(include "key_records.scm")
(include "common_records.scm")
|
︙ | | |
Modified launch.scm
from [6498c309e0]
to [a845528487].
︙ | | |
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
|
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
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
+
+
+
+
+
+
+
+
|
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
;; launch a task - this runs on the originating host, tests themselves
;;
;;======================================================================
(import
chicken.bitwise
chicken.condition
chicken.file
chicken.file.posix
chicken.io
chicken.pathname
chicken.port
chicken.pretty-print
chicken.process
chicken.process-context
chicken.process-context.posix
chicken.process.signal
chicken.sort
chicken.string
chicken.time
srfi-1
srfi-69
system-information
(use regex regex-case base64 sqlite3 srfi-18 directory-utils posix-extras z3
call-with-environment-variables csv)
(use typed-records pathname-expand matchable)
regex regex-case base64 sqlite3 srfi-18 directory-utils
;; posix-extras
z3
;; call-with-environment-variables csv)
typed-records pathname-expand matchable)
(import (prefix base64 base64:))
(import (prefix sqlite3 sqlite3:))
(declare (unit launch))
(declare (uses subrun))
(declare (uses common))
(declare (uses configf))
(declare (uses db))
(declare (uses ezsteps))
(define getenv get-environment-variable)
(define setenv set-environment-variable!)
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "megatest-fossil-hash.scm")
;;======================================================================
;; ezsteps
|
︙ | | |
Modified lock-queue.scm
from [21543b63ce]
to [cd6245939c].
︙ | | |
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
|
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
|
+
-
+
+
+
+
+
+
+
+
|
;; 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/>.
;;
(import
(use (prefix sqlite3 sqlite3:) srfi-18)
(prefix sqlite3 sqlite3:) srfi-18
chicken.file
chicken.process
chicken.time
sqlite3
chicken.condition
chicken.string
)
(declare (unit lock-queue))
(declare (uses common))
(declare (uses tasks))
;;======================================================================
;; attempt to prevent overlapping updates of rollup files by queueing
|
︙ | | |
245
246
247
248
249
250
251
252
253
|
253
254
255
256
257
258
259
260
261
|
-
+
|
(begin
(thread-sleep! 1)
(loop (lock-queue:any-younger? dbdat mystart test-id)))))))))
(sqlite3:finalize! db)
result))))))
;; (use trace)
;; (import trace)
;; (trace lock-queue:get-lock lock-queue:release-lock lock-queue:wait-turn lock-queue:any-younger? lock-queue:set-state)
|
Modified margs.scm
from [812fd1b225]
to [5bda76c250].
︙ | | |
14
15
16
17
18
19
20
21
22
23
24
25
26
27
|
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
|
+
+
+
+
+
|
;;
;; 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))
(import chicken.process-context
srfi-1
srfi-69
)
(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))))
|
︙ | | |
Modified megatest.scm
from [68c3e57406]
to [bf898c3d9e].
︙ | | |
56
57
58
59
60
61
62
63
64
65
66
67
68
69
|
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
89
90
91
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;; (declare (uses ftail))
;; (import ftail)
(import dbmod
commonmod
dbfile)
(import
chicken.condition
chicken.file
chicken.pathname
chicken.port
chicken.pretty-print
chicken.process
chicken.process-context
chicken.process-context.posix
chicken.process.signal
chicken.repl
chicken.sort
chicken.string
chicken.time
chicken.time.posix
srfi-1
srfi-13
srfi-69
system-information
)
(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")
(include "run_records.scm")
|
︙ | | |
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
|
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
|
-
+
|
(require-library mutils)
(define *usage-log-file* #f) ;; put path to file for logging usage in this var in the ~/.megatestrc file
(define *usage-use-seconds* #t) ;; for Epoc seconds in usage logging change this to #t in ~/.megatestrc file
(dbfile:db-init-proc db:initialize-main-db)
;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file
;; load the ~/.megatestrc file, put (import 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)
(load debugcontrolf)))
;; usage logging, careful with this, it is not designed to deal with all real world challenges!
;;
|
︙ | | |
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
|
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
|
-
+
|
-status : Applies to runs, tests or steps depending on context
-modepatt key : load testpatt from <key> in runconfigs instead of default TESTPATT if -testpatt and -tagexpr are not specified
-tagexpr tag1,tag2%,.. : select tests with tags matching expression
Test helpers (for use inside tests)
-step stepname
-test-status : set the state and status of a test (use :state and :status)
-test-status : set the state and status of a test (import :state and :status)
-setlog logfname : set the path/filename to the final log relative to the test
directory. may be used with -test-status
-set-toplog logfname : set the overall log for a suite of sub-tests
-summarize-items : for an itemized test create a summary html
-m comment : insert a comment for this test
Test data capture
|
︙ | | |
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
|
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
|
-
+
|
-refdb2dat refdb : convert refdb to sexp or to format specified by s-dumpmode
formats: perl, ruby, sqlite3, csv (for csv the -o param
will substitute %s for the sheet name in generating
multiple sheets)
-o : output file for refdb2dat (defaults to stdout)
-archive cmd : archive runs specified by selectors to one of disks specified
in the [archive-disks] section.
cmd: keep-html, restore, save, save-remove, get, replicate-db (use
cmd: keep-html, restore, save, save-remove, get, replicate-db (import
-dest to set destination), -include path1,path2... to get or save specific files
-generate-html : create a simple html dashboard for browsing your runs
-generate-html-structure : create a top level html veiw to list targets/runs and a Run view within each run directory.
-list-run-time : list time requered to complete runs. It supports following switches
-run-patt <patt> -target-patt <patt> -dumpmode <csv,json,plain-text>
-list-test-time : list time requered to complete each test in a run. It following following arguments
-runname <patt> -target <patt> -dumpmode <csv,json,plain-text>
|
︙ | | |
Modified mlaunch.scm
from [5bcd34288f]
to [2f32045134].
︙ | | |
21
22
23
24
25
26
27
28
29
30
31
32
33
|
21
22
23
24
25
26
27
28
29
30
31
32
33
|
-
+
|
;; MLAUNCH
;;
;; take jobs from the given queue and keep launching them keeping
;; the cpu load at the targeted level
;;
;;======================================================================
(use sqlite3 srfi-1 posix regex regex-case srfi-69 format)
(import sqlite3 srfi-1 posix regex regex-case srfi-69 format)
(declare (unit mlaunch))
(declare (uses db))
(declare (uses common))
|
Modified monitor.scm
from [3df55c85ea]
to [d34b3cb462].
︙ | | |
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
|
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
|
-
+
|
;; 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/>.
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking)
(import sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking)
(import (prefix sqlite3 sqlite3:))
(declare (unit runs))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
|
︙ | | |
Modified mt.scm
from [f748d1dc75]
to [7067982b74].
︙ | | |
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
|
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
|
+
+
+
+
+
-
+
+
+
+
+
+
+
+
+
+
+
|
;; 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/>.
;;
(import sqlite3 srfi-1
;; posix
regex regex-case srfi-69
;; dot-locking
(srfi 18)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) posix-extras directory-utils call-with-environment-variables)
;; posix-extras directory-utils call-with-environment-variables
chicken.file
chicken.port
chicken.pretty-print
chicken.process
chicken.process-context.posix
chicken.string
chicken.time
chicken.condition
chicken.process-context
)
(import (prefix sqlite3 sqlite3:))
(declare (unit mt))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
|
︙ | | |
Modified mtexec.scm
from [88aec5a8b6]
to [409a18a5b7].
︙ | | |
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
|
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
|
-
+
|
)
;; (declare (uses common))
(declare (uses margs))
(declare (uses configf))
;; (declare (uses rmt))
;; (use ducttape-lib)
;; (import ducttape-lib)
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
;; (require-library stml)
(define help (conc "
mtutil, part of the Megatest tool suite, documentation at http://www.kiatoa.com/fossils/megatest
|
︙ | | |
Modified mtut.scm
from [2967125a3c]
to [7f0da56a11].
︙ | | |
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
|
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
|
-
+
|
chicken.format
pkts regex regex-case
(prefix dbi dbi:)
(prefix sqlite3 sqlite3:)
nanomsg)
(use ducttape-lib)
(import ducttape-lib)
(include "megatest-fossil-hash.scm")
(require-library stml)
;; stuff for the mapper and checker functions
;;
|
︙ | | |
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
|
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
|
-
+
|
extra-dat: `(a ,runkey) ;; we need the run key for marking the run as launched
)))
(with-output-to-file
(conc pktsdir "/" uuid ".pkt")
(lambda ()
(print pkt))))))
;; (use trace)(trace create-run-pkt)
;; (import trace)(trace create-run-pkt)
(define (contains list x) (cond ((null? list) #f) ((eq? (car list) x) #t) (else (contains (cdr list) x))))
;; collect all needed data and create run pkts for contours with changed inputs
;;
(define (generate-run-pkts mtconf toppath)
(let ((std-runname (conc "sched" (time->string (seconds->local-time (current-seconds)) "%M%H%d")))
(packets-generated 0))
|
︙ | | |
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
|
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
|
-
+
|
(conc "megatest " (if (not (member action '("sync")))
(conc action " " action-param)
"") (if (member action '("-run" "-rerun-clean" "-rerun-all" "-kill-rerun"))
"-rerun DEAD,ABORT,KILLED"
""))
pkta)))
;; (use trace)(trace pkt->cmdline)
;; (import trace)(trace pkt->cmdline)
(define (write-pkt pktsdir uuid pkt)
(if pktsdir
(with-output-to-file
(conc pktsdir "/" uuid ".pkt")
(lambda ()
(print pkt)))
|
︙ | | |
Modified newdashboard.scm
from [3cc17ecae4]
to [788a889ee9].
︙ | | |
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
-
+
-
+
-
+
-
+
|
;; 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/>.
;;======================================================================
(use format)
(import format)
(use (prefix iup iup:))
(import (prefix iup iup:))
(use canvas-draw)
(import canvas-draw)
(import canvas-draw-iup)
(use sql-de-lite srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors ;; defstruct
(import sql-de-lite srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors ;; defstruct
(prefix dbi dbi:))
(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
;; (declare (uses launch))
|
︙ | | |
Modified ods.scm
from [42e94b826f]
to [3def5cd0a9].
︙ | | |
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
|
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
|
-
+
+
+
+
+
+
+
+
|
;; 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/>.
;;
(use csv-xml regex)
(import ;; csv-xml
chicken.port
chicken.process
chicken.string
regex
srfi-13
)
(declare (unit ods))
(declare (uses common))
(define ods:dirs
'("Configurations2"
"Configurations2/toolpanel"
"Configurations2/menubar"
|
︙ | | |
Modified portlogger.scm
from [db569cc07a]
to [3de8b12dc0].
︙ | | |
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
|
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
|
-
+
+
+
+
+
+
+
+
+
|
srfi-1
;; posix
srfi-69
;; hostinfo
;; dot-locking
z3
(prefix sqlite3 sqlite3:))
(prefix sqlite3 sqlite3:)
chicken.condition
chicken.file
chicken.process
chicken.process-context.posix
chicken.string
)
(declare (unit portlogger))
(declare (uses db))
;; lsof -i
(define (portlogger:open-db fname)
|
︙ | | |
Modified process.scm
from [f9dfbe5500]
to [06c118e3a3].
︙ | | |
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
|
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
|
+
-
+
+
+
+
+
+
+
+
+
|
;;======================================================================
;;======================================================================
;; Process convience utils
;;======================================================================
(import
(use regex directory-utils)
regex directory-utils
chicken.condition
chicken.file
chicken.io
chicken.process
chicken.process-context.posix
chicken.string
srfi-18
)
(declare (unit process))
(define (process:conservative-read port)
(let loop ((res ""))
(if (not (eof-object? (peek-char port)))
(loop (conc res (read-char port)))
res)))
|
︙ | | |
Modified records-vs-vectors-vs-coops.scm
from [a207631458]
to [1606cfd8b6].
︙ | | |
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
|
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
|
-
+
-
+
|
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;; (include "vg.scm")
;; (declare (uses vg))
(use foof-loop defstruct coops)
(import foof-loop defstruct coops)
(defstruct obj type fill-color angle)
(define (make-vg:obj)(make-vector 3))
(define-inline (vg:obj-get-type vec) (vector-ref vec 0))
(define-inline (vg:obj-get-fill-color vec) (vector-ref vec 1))
(define-inline (vg:obj-get-angle vec) (vector-ref vec 2))
(define-inline (vg:obj-set-type! vec val)(vector-set! vec 0 val))
(define-inline (vg:obj-set-fill-color! vec val)(vector-set! vec 1 val))
(define-inline (vg:obj-set-angle! vec val)(vector-set! vec 2 val))
(use simple-exceptions)
(import simple-exceptions)
(define vgs:obj-exn (make-exception "wrong record type, expected vgs:obj." 'assert))
(define (make-vgs:obj)(let ((v (make-vector 4)))(vector-set! v 0 'vgs:obj) v))
(define-inline (vgs:obj-type vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 1)(raise (vgs:obj-exn 'vgs:obj-type 'xpr))))
(define-inline (vgs:obj-fill-color vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 2)(raise (vgs:obj-exn 'vgs:obj-fill-color 'xpr))))
(define-inline (vgs:obj-angle vec)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-ref vec 3)(raise (vgs:obj-exn 'vgs:obj-angle 'xpr))))
(define-inline (vgs:obj-type-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 1 val)(raise (vgs:obj-exn 'type))))
(define-inline (vgs:obj-fill-color-set! vec val)(if (eq? (vector-ref vec 0) 'vgs:obj)(vector-set! vec 2 val)(raise (vgs:obj-exn 'fill-color))))
|
︙ | | |
Modified rmt.scm
from [3a21be5e2c]
to [d2f3a8de1e].
︙ | | |
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
|
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
|
+
+
+
+
+
+
+
+
+
+
+
+
-
+
|
;; 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/>.
;;
;;======================================================================
(import
format typed-records
chicken.condition
chicken.port
chicken.pretty-print
chicken.sort
chicken.string
chicken.time
srfi-1
srfi-18
srfi-69
(use format typed-records) ;; RADT => purpose of json format??
) ;; RADT => purpose of json format??
(declare (unit rmt))
(declare (uses api))
(declare (uses http-transport))
(declare (uses dbfile))
(include "common_records.scm")
;; (declare (uses rmtmod))
|
︙ | | |
Modified runconfig.scm
from [66b9c38588]
to [c379a381af].
︙ | | |
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
|
-
+
+
+
+
+
+
+
+
|
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
;; read a config file, loading only the section pertinent
;; to this run field1val/field2val/field3val ...
;;======================================================================
(use format directory-utils)
(import format directory-utils
chicken.port
chicken.pretty-print
chicken.string
chicken.time
srfi-1
srfi-69
chicken.process-context)
(declare (unit runconfig))
(declare (uses common))
(include "common_records.scm")
(define (runconfig:read fname target environ-patt)
|
︙ | | |
Modified runs-launch-loop-test.scm
from [a4977cdfc7]
to [a8abe5abb0].
︙ | | |
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
|
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
|
-
+
|
;; 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/>.
;;
(use srfi-69)
(import srfi-69)
(define (runs:queue-next-hed tal reg n regful)
(if regful
(car reg)
(car tal)))
(define (runs:queue-next-tal tal reg n regful)
|
︙ | | |
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
|
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
|
-
+
|
(define (runs:queue-next-reg tal reg n regful)
(if regful
(cdr reg)
(if (eq? (length tal) 1)
'()
reg)))
(use trace)
(import trace)
(trace runs:queue-next-hed
runs:queue-next-tal
runs:queue-next-reg)
(define tests '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20))
|
︙ | | |
Modified runs.scm
from [9dc99d390b]
to [cd01c3c10b].
︙ | | |
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
|
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
|
-
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
(import
(prefix sqlite3 sqlite3:) srfi-1
;; posix
regex regex-case srfi-69 (srfi 18)
regex regex-case srfi-69 (srfi 18)
srfi-13
;; posix-extras directory-utils pathname-expand
typed-records format sxml-serializer
sxml-modifications matchable)
sxml-modifications matchable
chicken.condition
chicken.file
chicken.file.posix
chicken.io
chicken.port
chicken.pretty-print
chicken.process
chicken.process-context
chicken.process-context.posix
chicken.process.signal
chicken.sort
chicken.string
chicken.time
chicken.time.posix
system-information
)
(declare (unit runs))
(declare (uses db))
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
|
︙ | | |
Modified sauthorize.scm
from [b4d2f08e65]
to [8c9a038964].
︙ | | |
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
|
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
|
-
-
+
+
-
-
-
+
+
+
-
+
|
;; 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/>.
;;
(use defstruct)
(use scsh-process)
(import defstruct)
(import scsh-process)
(use srfi-18)
(use srfi-19)
(use refdb)
(import srfi-18)
(import srfi-19)
(import refdb)
(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
(import sql-de-lite srfi-1 posix regex regex-case srfi-69)
;(declare (uses common))
;(declare (uses configf))
(declare (uses margs))
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm.
|
︙ | | |
Modified serialize-env.scm
from [e0a42785e8]
to [1b1989d604].
1
2
3
4
5
6
7
8
9
|
1
2
3
4
5
6
7
8
9
|
-
-
+
+
|
(use z3)
(use base64)
(import z3)
(import base64)
(let* ((env-str (with-output-to-string (lambda () (pp (get-environment-variables)))))
(zipped-env-str (z3:encode-buffer env-str))
(b64-env-str (base64-encode zipped-env-str)))
(print b64-env-str))
|
Modified server.scm
from [a060e1f916]
to [773b031b2e].
︙ | | |
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
|
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
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
+
-
+
|
;; 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/>.
;;
(import
chicken.file
chicken.file.posix
chicken.io
chicken.port
chicken.pretty-print
chicken.process
chicken.process-context
chicken.process-context.posix
chicken.sort
chicken.string
chicken.time
srfi-4
system-information
(srfi 18)
(srfi 18)
;; extras
chicken.tcp
s11n
srfi-1
;; posix
regex regex-case srfi-69
;; hostinfo
md5 message-digest
;; directory-utils posix-extras
matchable
;; utils
chicken.condition
spiffy uri-common intarweb http-client spiffy-request-vars
)
(declare (unit server))
(declare (uses commonmod))
|
︙ | | |
Modified sharedat.scm
from [bb858ca5c8]
to [fa72910130].
︙ | | |
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
|
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
|
-
+
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
-
+
|
;; 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/>.
(use defstruct)
(import defstruct)
;; (use ssax)
;; (use sxml-serializer)
;; (use sxml-modifications)
;; (use regex)
;; (use srfi-69)
;; (use regex-case)
;; (use posix)
;; (use json)
;; (use csv)
(use srfi-18)
(use format)
;; (import ssax)
;; (import sxml-serializer)
;; (import sxml-modifications)
;; (import regex)
;; (import srfi-69)
;; (import regex-case)
;; (import posix)
;; (import json)
;; (import csv)
(import srfi-18)
(import format)
(require-library ini-file)
(import (prefix ini-file ini:))
(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
(import sql-de-lite srfi-1 posix regex regex-case srfi-69)
;; (import (prefix sqlite3 sqlite3:))
;;
(declare (uses configf))
;; (declare (uses tree))
(declare (uses margs))
;; (declare (uses dcommon))
;; (declare (uses launch))
|
︙ | | |
Modified spublish.scm
from [ec4585c620]
to [b7c6787528].
︙ | | |
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
|
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
|
-
-
-
-
-
-
-
+
+
+
+
+
+
+
-
+
|
;; 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/>.
(use defstruct)
(use scsh-process)
(use refdb)
(use srfi-18)
(use srfi-19)
(use format)
(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
(import defstruct)
(import scsh-process)
(import refdb)
(import srfi-18)
(import srfi-19)
(import format)
(import sql-de-lite srfi-1 posix regex regex-case srfi-69)
;(declare (uses configf))
;; (declare (uses tree))
(declare (uses margs))
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm.
(include "sauth-paths.scm")
(include "sauth-common.scm")
(define (toplevel-command . args) #f)
(use readline)
(import readline)
;;
;; GLOBALS
;;
(define *spublish:current-tab-number* 0)
(define *args-hash* (make-hash-table))
(define spublish:help (conc "Usage: spublish [action [params ...]]
|
︙ | | |
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
|
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
|
-
+
|
Version: " megatest-fossil-hash)
)
(define (toplevel-command . args) #f)
(define (spublish:shell area)
; (print area)
(use readline)
(import readline)
(let* ((path '())
(prompt "spublish> ")
(args (argv))
(usr (current-user-name) )
(top-areas (spublish:get-accessable-projects area))
(close-port #f)
|
︙ | | |
Modified sretrieve.scm
from [bc076b5abf]
to [aa4d41882f].
︙ | | |
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
|
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
|
-
-
-
-
-
-
+
+
+
+
+
+
-
+
|
;; 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/>.
;;
(use defstruct)
(use scsh-process)
(use srfi-18)
(use srfi-19)
(use refdb)
(use sql-de-lite srfi-1 posix regex regex-case srfi-69)
(import defstruct)
(import scsh-process)
(import srfi-18)
(import srfi-19)
(import refdb)
(import sql-de-lite srfi-1 posix regex regex-case srfi-69)
;(declare (uses common))
;(declare (uses configf))
(declare (uses margs))
(include "megatest-version.scm")
(include "megatest-fossil-hash.scm")
;;; please create this file before using sautherise. For sample file is avaliable sample-sauth-paths.scm.
(include "sauth-paths.scm")
(include "sauth-common.scm")
(define (toplevel-command . args) #f)
(use readline)
(import readline)
;;
;; GLOBALS
;;
|
︙ | | |
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
|
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
|
-
+
|
Learn more at http://www.kiatoa.com/fossils/megatest
Version: " megatest-fossil-hash)
)
;(define (toplevel-command . args) #f)
(define (sretrieve:shell area)
; (print area)
(use readline)
(import readline)
(let* ((path '())
(prompt "sretrieve> ")
(args (argv))
(usr (current-user-name) )
(top-areas (sretrieve:get-accessable-projects area))
(close-port #f)
(area-obj (get-obj-by-code area))
|
︙ | | |
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
|
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
|
-
+
|
; (make-hash-table))))
; (pop-directory)
; res)))
(define (toplevel-command . args) #f)
(define (sretrieve:process-action action . args)
; (print action)
; (use readline)
; (import readline)
(case (string->symbol action)
((get)
(if (< (length args) 2)
(begin
(sauth:print-error "Missing arguments; <area> <relative path>" )
(exit 1)))
(let* ((remargs (args:get-args args '("-m" ) '() args:arg-hash 0))
|
︙ | | |
Modified stml2/cookie.scm
from [d78a525a3a]
to [fba413a4c8].
︙ | | |
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
|
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
|
-
+
|
;; <http://www.netscape.com/newsref/std/cookie_spec.html>
;; (declare (unit cookie))
(module cookie
*
(import chicken scheme data-structures extras srfi-13 ports posix)
(import (chicken base) scheme queues srfi-13 (chicken port) (chicken io)(chicken file) (chicken format) (chicken string) (chicken time posix))
(require-extension srfi-1 srfi-13 srfi-14 regex)
;; (use srfi-1 srfi-13 srfi-14 regex)
;; (declare (export parse-cookie-string construct-cookie-string))
;; #>
;; #include <time.h>
|
︙ | | |
Modified stml2/formdat.scm
from [f4b16c20f8]
to [0f3102ec8c].
︙ | | |
8
9
10
11
12
13
14
15
16
17
18
19
20
21
|
8
9
10
11
12
13
14
15
16
17
18
19
20
|
-
+
-
-
-
+
+
|
;; PURPOSE.
;; (declare (unit formdat))
(module formdat
*
(import chicken scheme data-structures extras srfi-13 ports )
(import chicken scheme data-structures extras srfi-13 ports html-filter)
(use html-filter)
(use regex)
(require-extension srfi-69)
(import regex)
(import srfi-69)
)
|
Modified stml2/html-filter.scm
from [55ec64cff2]
to [a2ae004691].
︙ | | |
9
10
11
12
13
14
15
16
17
18
19
20
21
|
9
10
11
12
13
14
15
16
17
18
19
20
21
|
-
+
-
+
|
;; (declare (unit html-filter))
(module html-filter
*
(import chicken scheme data-structures extras srfi-13 ports )
(use misc-stml)
(import misc-stml)
(require-extension regex)
(import regex)
;;
)
|
Modified stml2/misc-stml.scm
from [30ba5d90bf]
to [8660d67355].
︙ | | |
14
15
16
17
18
19
20
21
22
23
24
|
14
15
16
17
18
19
20
21
22
23
|
-
-
+
+
-
|
;; (declare (unit misc-stml))
(module misc-stml
*
(import chicken scheme data-structures extras srfi-13 ports posix)
(use regex (prefix dbi dbi:))
(use (prefix crypt c:))
(import regex (prefix dbi dbi:))
(import (prefix crypt c:))
(use (prefix dbi dbi:))
)
|
Modified stml2/rollup-pages.scm
from [b24bc2e231]
to [37b97898ac].
1
2
3
4
5
6
7
8
|
1
2
3
4
5
6
7
8
|
-
+
|
(use regex posix srfi-69 srfi-1)
(import regex posix srfi-69 srfi-1)
(define extract-rx (regexp "pages\\/(.*)_(view|ctrl).scm"))
(define (print-page-wrapper lookup page)
(print "(define (pages:" page " session db shared)")
(if (hash-table-ref/default lookup (conc page "_ctrl") #f)
(print "(include \"pages/" page "_ctrl.scm\")"))
|
︙ | | |
Modified stml2/session.scm
from [300e7014a0]
to [32b68ce58f].
︙ | | |
9
10
11
12
13
14
15
16
17
18
19
20
|
9
10
11
12
13
14
15
16
17
18
19
|
-
+
-
-
+
|
;; (declare (unit session))
(module session
*
(import chicken scheme data-structures extras srfi-13 ports posix files srfi-1)
(use (prefix dbi dbi:) srfi-69)
(import (prefix dbi dbi:) srfi-69 regex)
(require-extension regex)
(use cookie stmlcommon) ;; (declare (uses cookie))
(import cookie stmlcommon) ;; (declare (uses cookie))
)
|
Modified stml2/setup.scm
from [27fec5f813]
to [6248624979].
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
|
-
+
-
+
-
|
;; Copyright 2007-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.
(module setup
*
(import chicken scheme data-structures extras srfi-13 ports posix)
(uses session misc-stml)
(import session misc-stml)
;; (declare (unit setup))se
;; (declare (uses session))
(require-extension srfi-69)
(import srfi-69 regex)
(require-extension regex)
)
|
Modified stml2/spiffyserver.scm
from [0953505b2d]
to [36a130548d].
1
2
3
4
5
6
7
8
9
10
|
1
2
3
4
5
6
7
8
9
10
|
-
+
|
;; This doesn't work yet
;;
(use spiffy cgi-handler)
(import spiffy cgi-handler)
(spiffy-debug-mode #t)
(spiffy-file-ext-handlers
`(("drcdb" . ,(cgi-handler* "/path/to/drcdb"))))
(spiffy-root-path "/path/to/web")
|
︙ | | |
Modified stml2/sqlite3.scm
from [935dbe7787]
to [b0bb736749].
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
|
-
+
|
;; Copyright 2007-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.
;;
;; I used this to get a simple interactive sqlite editor on the nokia n800
;; since I couldn't get sqlite3 to install (for reasons I can't remember).
(use sqlite3)
(import sqlite3)
(define args (argv))
(define num-args (length args))
(define dbname #f)
(define cmd #f)
|
︙ | | |
Modified stml2/stml2.scm
from [ee4c13898d]
to [ccb26a2824].
︙ | | |
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
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
|
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
+
+
+
+
+
+
-
-
+
|
;; stml is a list of html strings
;; (declare (unit stml))
(module stml2
*
(import chicken scheme data-structures extras srfi-13 ports posix srfi-69 files srfi-1)
(import
(chicken base)
(chicken blob)
(chicken condition)
(chicken file)
(chicken format)
(chicken io)
(chicken pathname)
(chicken port)
(chicken process)
(chicken process-context posix)
(chicken process-context)
(chicken random)
(chicken string)
(chicken time posix)
(chicken time)
(prefix crypt c:)
(prefix dbi dbi:)
(import cookie)
(use (prefix dbi dbi:) (prefix crypt c:) typed-records)
cookie
queues
regex
scheme
srfi-1
srfi-13
srfi-69
typed-records
;; (declare (uses misc-stml))
(use regex)
)
;; The (usually global) sdat contains everything about the session
;;
(defstruct sdat
;; database
(dbtype 'pg)
(dbinit #f)
|
︙ | | |
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
|
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
|
-
+
|
;; to obscure and indirect database ids use one time keys
;;
;; (s:get-key 'n 1) => "n99e1882" n=number 99e is the week number since 1970, remainder is random
;; (s:key->val "n1882") => 1
;;
;; first letter is a type: n=number, s=string, b=boolean
(define (s:get-key key-type val)
(let ((mkrandstr (lambda (innum)(number->string (random innum) 16)))
(let ((mkrandstr (lambda (innum)(number->string (pseudo-random-integer innum) 16)))
(week (number->string (quotient (current-seconds) (* 7 24 60 60)) 16)))
(let loop ((siz 1000)
(key (conc key-type week (mkrandstr 100)))
(num 0))
(if (s:session-var-get key) ;; have a collision
(loop (cond ;; in the unlikey event we have trouble getting a new var, keep increasing the size of the number
((< num 50) 100)
|
︙ | | |
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
|
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
|
-
+
-
+
|
#;(define session:valid-chars "abcdefghijklmnopqrstuvwxyz0123456789") ;; cookies are case insensitive.
#;(define session:num-valid-chars (string-length session:valid-chars))
#;(define (session:get-nth-char nth)
(substring session:valid-chars nth (+ nth 1)))
#;(define (session:get-rand-char)
(session:get-nth-char (random session:num-valid-chars)))
(session:get-nth-char (pseudo-random-integer session:num-valid-chars)))
#;(define (session:make-rand-string len)
(let loop ((res "")
(n 1))
(if (> n len) res
(loop (string-append res (session:get-rand-char))
(+ n 1)))))
;; maybe replace above make-rand-string with this someday?
;;
#;(define (session:generic-make-rand-string len seed-string)
(let ((num-chars (string-length seed-string)))
(let loop ((res "")
(n 1))
(let ((char-num (random num-chars)))
(let ((char-num (pseudo-random-integer num-chars)))
(if (> n len) res
(loop (string-append res (substring seed-string char-num (+ char-num 1)))
(+ n 1)))))))
;; Rely on crypt egg's default settings being secure enough, accept
;; backwards-compatible OpenSSL crypt passwords too.
;;
|
︙ | | |
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
|
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
|
-
-
+
+
|
((string? val) (string->number val))
((symbol? val) (string->number (symbol->string val)))
(else #f)))
;; NB// this is *illegal* pgint
(define (s:illegal-pgint val)
(cond
((> val 2147483647) 1)
((< val -2147483648) -1)
((> val 2147483640.0) 1) ;; 2147483647
((< val -2147483640.0) -1) ;; -2147483648
(else #f)))
(define (s:any->pgint val)
(let ((n (s:any->number val)))
(if n
(if (s:illegal-pgint n)
#f
|
︙ | | |
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
|
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
|
-
+
-
+
-
+
|
(formdat:load-all-port (current-input-port))
(make-formdat:formdat))))
;; (s:process-cgi-input (caaar dat))
(define (formdat:load-all-port inp)
(let* ((formdat (make-formdat:formdat))
(debugp #f))
;; (open-output-file (conc "/tmp/delme-" (current-user-id) ".log"))))
;; (open-output-file (conc "/tmp/delme-" (current-user-id) ".log"))))
;; (write-string (read-string #f inp) #f debugp) ;; destroys all data!
(formdat:initialize formdat)
(let ((alldats (formdat:dat->list inp 10e6 debug-port: debugp)))
(let ((alldats (formdat:dat->list inp 10e6 debug-port: #f debugp)))
(if debugp (format debugp "formdat : alldats: ~A\n" alldats))
#;(if debugp (format debugp "formdat : alldats: ~A\n" alldats))
(let ((firstitem (car alldats))
(multipass #f))
(if (and (not (null? firstitem))
(not (null? (car firstitem))))
(if (string-match formdat:delim-patt-rex (caar firstitem))
(set! multipass #t)))
|
︙ | | |
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
|
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
|
-
+
|
;; (munged (s:process-cgi-input datstr)))
;; (print "datstr: " datstr " munged: " munged)
(if (and (not (null? alldats))
(not (null? (car alldats)))
(not (null? (caar alldats))))
(formdat:load formdat (s:process-cgi-input (caaar alldats))))) ;; munged))
;; (format debugp "formdat : name: ~A content: ~A\n" name content)
(if debugp (close-output-port debugp))
#;(if debugp (close-output-port debugp))
;; (sdat-formdat-set! s:session formdat)
formdat))))
#|
(define inp (open-input-file "tests/example.post.in"))
(define dat (read-string #f inp))
(define datstr (open-input-string dat))
|
︙ | | |
1427
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
|
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
|
-
+
-
+
|
(define session:valid-chars "abcdefghijklmnopqrstuvwxyz0123456789") ;; cookies are case insensitive.
(define session:num-valid-chars (string-length session:valid-chars))
(define (session:get-nth-char nth)
(substring session:valid-chars nth (+ nth 1)))
(define (session:get-rand-char)
(session:get-nth-char (random session:num-valid-chars)))
(session:get-nth-char (pseudo-random-integer session:num-valid-chars)))
(define (session:make-rand-string len)
(let loop ((res "")
(n 1))
(if (> n len) res
(loop (string-append res (session:get-rand-char))
(+ n 1)))))
;; maybe replace above make-rand-string with this someday?
;;
(define (session:generic-make-rand-string len seed-string)
(let ((num-chars (string-length seed-string)))
(let loop ((res "")
(n 1))
(let ((char-num (random num-chars)))
(let ((char-num (pseudo-random-integer num-chars)))
(if (> n len) res
(loop (string-append res (substring seed-string char-num (+ char-num 1)))
(+ n 1)))))))
;;======================================================================
;; P A R A M S
|
︙ | | |
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
|
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
|
-
+
|
(if debugmode (session:log self "session:setup dbfname=" dbfname ", dbtype=" dbtype ", dbinit=" dbinit))
(if (eq? dbtype 'sqlite3)
;; The 'auto method will distribute dbs across the disk using hash
;; of user host and user. TODO
;; (if (eq? dbfname 'auto) ;; This is the auto assignment of a db based on hash of IP
(let ((dbpath (pathname-directory dbfname))) ;; do a couple sanity checks here to make setting up easier
(if debugmode (session:log self "INFO: setting up for sqlite3 db access to " dbfname))
(if (not (file-write-access? dbpath))
(if (not (file-writable? dbpath))
(session:log self "WARNING: Cannot write to " dbpath)
(if debugmode (session:log self "INFO: " dbpath " is writeable")))
(if (file-exists? dbfname)
(begin
;; (session:log self "setting dbexists to #t")
(set! dbexists #t))))
(if debugmode (session:log self "INFO: setting up for pg db access to account info " dbinit)))
|
︙ | | |
Modified stml2/stmlcommon.scm
from [d0639f2742]
to [ba756fc30d].
︙ | | |
11
12
13
14
15
16
17
18
19
20
|
11
12
13
14
15
16
17
18
19
20
|
-
+
|
;; (declare (run-time-macros))
(module stmlcommon
*
(import chicken scheme data-structures extras srfi-13 ports posix)
(use (prefix dbi dbi:) regex (prefix crypt c:) srfi-69)
(import (prefix dbi dbi:) regex (prefix crypt c:) srfi-69)
)
|
Modified stml2/stmlrun.scm
from [a5be661fee]
to [4939b15c7b].
︙ | | |
9
10
11
12
13
14
15
16
17
18
19
|
9
10
11
12
13
14
15
16
17
18
19
|
-
+
|
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;; (require-extension syntax-case)
;; (declare (run-time-macros))
;; (include "stmlcommon.scm")
(require-library stml)
(import stml)
(stml:main #f)
|
Modified stml2/test.scm
from [62a996e095]
to [6d65a60d4d].
1
2
3
4
5
6
7
8
9
10
|
1
2
3
4
5
6
7
8
9
|
-
+
-
|
(use test md5)
(import test md5)
(require-extension sqlite3)
(import (prefix sqlite3 sqlite3:))
(require-library dbi)
;; (declare (uses stml))
(include "requirements.scm")
|
︙ | | |
Modified subrun.scm
from [85650ceb7f]
to [e936eca57e].
︙ | | |
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
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
|
+
+
+
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;; 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/>.
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
(import
(prefix sqlite3 sqlite3:) srfi-1
;; posix
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18)
posix-extras directory-utils pathname-expand typed-records format
call-with-environment-variables)
regex regex-case srfi-69 (srfi 18)
;; posix-extras directory-utils pathname-expand
typed-records
;; format
;; call-with-environment-variables
chicken.file
chicken.file.posix
chicken.irregex
chicken.process
chicken.string
chicken.time
chicken.process-context
)
(declare (unit subrun))
;;(declare (uses runs))
(declare (uses db))
(declare (uses common))
;;(declare (uses items))
;;(declare (uses runconfig))
;;(declare (uses tests))
|
︙ | | |
Modified synchash.scm
from [6d4566e942]
to [47f37d4047].
︙ | | |
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
|
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
|
-
-
+
+
|
;;
;;======================================================================
;;======================================================================
;; A hash of hashes that can be kept in sync by sending minial deltas
;;======================================================================
(use format)
(use srfi-1 srfi-69 sqlite3)
(import format)
(import srfi-1 srfi-69 sqlite3)
(import (prefix sqlite3 sqlite3:))
(declare (unit synchash))
(declare (uses db))
(declare (uses server))
(include "db_records.scm")
|
︙ | | |
Modified tasks.scm
from [6ee51506d0]
to [05a51f6f23].
︙ | | |
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
|
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
|
+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(declare (unit tasks))
(declare (uses dbfile))
(declare (uses db))
(declare (uses rmt))
(declare (uses common))
(declare (uses pgdb))
(import
sqlite3 srfi-1
;; posix
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format)
(import (prefix sqlite3 sqlite3:))
regex regex-case srfi-69
;; dot-locking
format
(prefix sqlite3 sqlite3:)
chicken.condition
chicken.file
chicken.file.posix
chicken.process
chicken.process-context.posix
chicken.process.signal
chicken.string
chicken.time
srfi-18
srfi-13
system-information
)
(import dbfile)
;; (import pgdb) ;; pgdb is a module
(include "task_records.scm")
(include "db_records.scm")
|
︙ | | |
Modified tcmt.scm
from [6658a745e5]
to [d57bd1678e].
︙ | | |
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
|
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
|
+
+
+
-
+
-
+
|
;;
;; Wrapper to enable running Megatest flows under teamcity
;;
;; 1. Run the megatest process and pass it all the needed parameters
;; 2. Every five seconds check for state/status changes and print the info
;;
(import
srfi-1
;; posix
(use srfi-1 posix srfi-69 srfi-18 regex defstruct)
srfi-69 srfi-18 regex defstruct)
(use trace)
(import trace)
;; (trace-call-sites #t)
(declare (uses margs))
(declare (uses rmt))
(declare (uses common))
;; (declare (uses megatest-version))
|
︙ | | |
Modified tdb.scm
from [753c51811c]
to [0e9c91a2d6].
︙ | | |
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
|
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
|
-
+
+
+
+
+
+
+
+
+
+
+
|
(srfi 18)
;; extras tcp)
sqlite3 srfi-1
;; posix regex regex-case srfi-69 csv-xml s11n md5 message-digest base64
(prefix sqlite3 sqlite3:)
(prefix base64 base64:))
(prefix base64 base64:)
chicken.file.posix
chicken.io
chicken.port
chicken.pretty-print
chicken.sort
chicken.string
chicken.time
chicken.condition
srfi-69
)
(declare (unit tdb))
(declare (uses common))
(declare (uses keys))
(declare (uses ods))
(declare (uses client))
(declare (uses mt))
|
︙ | | |
Modified tests.scm
from [673927d3ed]
to [b4f35f97f8].
︙ | | |
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
|
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
|
-
+
+
+
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(declare (uses tdb))
(declare (uses common))
;; (declare (uses dcommon)) ;; needed for the steps processing
(declare (uses items))
(declare (uses runconfig))
;; (declare (uses sdb))
(declare (uses server))
;;(declare (uses stml2))
(declare (uses stml2))
(import
sqlite3 srfi-1
(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
(import (prefix sqlite3 sqlite3:))
(require-library stml)
;; posix regex regex-case srfi-69
;; dot-locking
;; tcp directory-utils
(prefix sqlite3 sqlite3:)
stml2
chicken.condition
chicken.file
chicken.file.posix
chicken.format
chicken.io
chicken.pathname
chicken.port
chicken.pretty-print
chicken.process
chicken.process-context
chicken.process-context.posix
chicken.sort
chicken.string
chicken.time
srfi-13
srfi-18
srfi-69
system-information
regex
)
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
(include "js-path.scm")
|
︙ | | |
Modified tree.scm
from [5b84d6f782]
to [7999e1ac4f].
︙ | | |
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
|
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
|
-
+
-
+
+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
|
;; 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/>.
;;
;;======================================================================
(use format)
(import format)
(require-library iup)
(import (prefix iup iup:))
(use canvas-draw)
(import canvas-draw)
(import
sqlite3 srfi-1
;; posix
(use sqlite3 srfi-1 posix regex regex-case srfi-69)
(import (prefix sqlite3 sqlite3:))
regex regex-case srfi-69
(prefix sqlite3 sqlite3:)
chicken.port
chicken.pretty-print
chicken.string
chicken.time
srfi-13
chicken.bitwise
srfi-69
)
(declare (unit tree))
(declare (uses margs))
(declare (uses launch))
;; (declare (uses megatest-version))
(declare (uses gutils))
(declare (uses db))
|
︙ | | |
Added utils/makemodulewrap.sh version [65cf1871f5].
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
#!/bin/bash
MODNAME=$1
mkdir -p tmpmods
echo "(module $MODNAME
*
(import
scheme
chicken.base)
(include \"$MODNAME.scm\")
)" > tmpmods/$MODNAME.scm
|
| | | | | | | | | | | | | |
Modified vg-test.scm
from [ee1267e1a2]
to [8e587b6efd].
︙ | | |
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
|
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
|
-
+
-
+
|
;; 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/>.
;;
(use canvas-draw iup foof-loop)
(import canvas-draw iup foof-loop)
(import canvas-draw-iup)
(load "vg.scm")
(define numtorun 1000)
;; (if (> (length (argv)) 1)
;; (string->number (cadr (argv)))
;; 1000))
(use trace)
(import trace)
;; (trace
;; ;; vg:draw-rect
;; ;; vg:grow-rect
;; vg:get-extents-for-objs
;; vg:components-get-extents
;; vg:instances-get-extents
;; vg:get-extents-for-two-rects
|
︙ | | |
Modified vg.scm
from [48b3b2908c]
to [f4607925e0].
︙ | | |
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
|
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
|
-
+
-
-
+
+
+
+
+
+
+
|
;; 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/>.
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
(use typed-records srfi-1)
(import typed-records srfi-1)
(declare (unit vg))
(use canvas-draw iup)
(import canvas-draw-iup)
(import canvas-draw iup)
(import
canvas-draw-iup
chicken.bitwise
srfi-69
chicken.string
)
(include "vg_records.scm")
;; ;; structs
;; ;;
;; (defstruct vg:lib comps)
;; (defstruct vg:comp objs name file)
|
︙ | | |
Modified vg_records.scm
from [67dafc9ef0]
to [fd7139b2bc].
︙ | | |
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
|
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
|
-
+
-
+
-
+
|
;; 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/>.
;;
(use simple-exceptions)
(import simple-exceptions)
(define vg:lib-exn (make-exception "wrong record type, expected vg:lib." 'assert))
(define (pmake-vg:lib . params)(let ((v (if (null? params)(make-vector 2)(apply vector 'vg:lib params)))) v))
(define (make-vg:lib #!key
(comps #f)
)
(vector 'vg:lib comps))
(define-inline (vg:lib-comps vec)(if (eq? (vector-ref vec 0) 'vg:lib)(vector-ref vec 1)(raise (vg:lib-exn 'vg:lib-comps 'xpr))))
(define-inline (vg:lib-comps-set! vec val)(if (eq? (vector-ref vec 0) 'vg:lib)(vector-set! vec 1 val)(raise (vg:lib-exn 'comps))))
;; Generated using make-vector-record -safe vg comp objs name file
(use simple-exceptions)
(import simple-exceptions)
(define vg:comp-exn (make-exception "wrong record type, expected vg:comp." 'assert))
(define (pmake-vg:comp . params)(let ((v (if (null? params)(make-vector 4)(apply vector 'vg:comp params)))) v))
(define (make-vg:comp #!key
(objs #f)
(name #f)
(file #f)
)
(vector 'vg:comp objs name file))
(define-inline (vg:comp-objs vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref vec 1)(raise (vg:comp-exn 'vg:comp-objs 'xpr))))
(define-inline (vg:comp-name vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref vec 2)(raise (vg:comp-exn 'vg:comp-name 'xpr))))
(define-inline (vg:comp-file vec)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-ref vec 3)(raise (vg:comp-exn 'vg:comp-file 'xpr))))
(define-inline (vg:comp-objs-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 1 val)(raise (vg:comp-exn 'objs))))
(define-inline (vg:comp-name-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 2 val)(raise (vg:comp-exn 'name))))
(define-inline (vg:comp-file-set! vec val)(if (eq? (vector-ref vec 0) 'vg:comp)(vector-set! vec 3 val)(raise (vg:comp-exn 'file))))
;; Generated using make-vector-record -safe vg obj type pts fill-color text line-color call-back angle font attrib extents proc
(use simple-exceptions)
(import simple-exceptions)
(define vg:obj-exn (make-exception "wrong record type, expected vg:obj." 'assert))
(define (pmake-vg:obj . params)(let ((v (if (null? params)(make-vector 12)(apply vector 'vg:obj params)))) v))
(define (make-vg:obj #!key
(type #f)
(pts #f)
(fill-color #f)
(text #f)
|
︙ | | |
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
|
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
|
-
+
|
(define-inline (vg:obj-angle-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 7 val)(raise (vg:obj-exn 'angle))))
(define-inline (vg:obj-font-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 8 val)(raise (vg:obj-exn 'font))))
(define-inline (vg:obj-attrib-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 9 val)(raise (vg:obj-exn 'attrib))))
(define-inline (vg:obj-extents-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 10 val)(raise (vg:obj-exn 'extents))))
(define-inline (vg:obj-proc-set! vec val)(if (eq? (vector-ref vec 0) 'vg:obj)(vector-set! vec 11 val)(raise (vg:obj-exn 'proc))))
;; Generated using make-vector-record -safe vg inst libname compname theta xoff yoff scalex scaley mirrx mirry call-back cache
(use simple-exceptions)
(import simple-exceptions)
(define vg:inst-exn (make-exception "wrong record type, expected vg:inst." 'assert))
(define (pmake-vg:inst . params)(let ((v (if (null? params)(make-vector 12)(apply vector 'vg:inst params)))) v))
(define (make-vg:inst #!key
(libname #f)
(compname #f)
(theta #f)
(xoff #f)
|
︙ | | |
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
|
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
|
-
+
|
(define-inline (vg:inst-scaley-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 7 val)(raise (vg:inst-exn 'scaley))))
(define-inline (vg:inst-mirrx-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 8 val)(raise (vg:inst-exn 'mirrx))))
(define-inline (vg:inst-mirry-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 9 val)(raise (vg:inst-exn 'mirry))))
(define-inline (vg:inst-call-back-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 10 val)(raise (vg:inst-exn 'call-back))))
(define-inline (vg:inst-cache-set! vec val)(if (eq? (vector-ref vec 0) 'vg:inst)(vector-set! vec 11 val)(raise (vg:inst-exn 'cache))))
;; Generated using make-vector-record -safe vg drawing libs insts scalex scaley xoff yoff cnv cache
(use simple-exceptions)
(import simple-exceptions)
(define vg:drawing-exn (make-exception "wrong record type, expected vg:drawing." 'assert))
(define (pmake-vg:drawing . params)(let ((v (if (null? params)(make-vector 9)(apply vector 'vg:drawing params)))) v))
(define (make-vg:drawing #!key
(libs #f)
(insts #f)
(scalex #f)
(scaley #f)
|
︙ | | |