Megatest

Changes On Branch 5de2fd17b5348d52
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Hide Diff Patch Side-by-Side Diff

Changes In Branch v1.65-broken Through [5de2fd17b5] Excluding Merge-Ins

This is equivalent to a diff from 367ffc5bdf to 5de2fd17b5

2020-05-31
21:19
Cherrypick 0495fb 2a858 from v1.65-broken. Better support for utilizing MT_ vars to fill defaults when -target, -testpatt, etc. are not specified check-in: 74a0e98868 user: mrwellan tags: v1.65
19:49
Cherrypick 0495fb 2a858 from v1.65-broken. check-in: fb39cefbf1 user: mrwellan tags: v1.65-cpick01
16:48
Pulled in changes only related to fixes from newview branch Closed-Leaf check-in: 4d6ba57051 user: matt tags: v1.65-oops-n
2020-05-27
12:46
Create new branch named "v1.65-junit-xml" check-in: 473d6eaf82 user: pjhatwal tags: v1.65-junit-xml
2020-04-27
17:46
Archive get now works well check-in: 0645166f9c user: mrwellan tags: v1.65-broken
2020-04-21
04:13
Get data from archive partially working check-in: 5de2fd17b5 user: mrwellan tags: v1.65-broken
2020-04-20
23:38
Fixed typo check-in: 2a858c5054 user: mrwellan tags: v1.65-broken
21:49
Merged newview work into v1.65 to minimize divergences check-in: 3b86fd8d4c user: mrwellan tags: v1.65-broken
2020-04-06
16:21
Merged in v1.65 check-in: db55d34798 user: mrwellan tags: v1.65-newview
2020-03-10
15:14
merged branch check-in: 367ffc5bdf user: mmgraham tags: v1.65, v1.6545
15:14
Updated Version check-in: e1e57863ea user: jmoon18 tags: v1.65
2020-03-05
16:45
Fixed the removal of test and run directories. Leaf check-in: e24a447e39 user: mmgraham tags: v1.65-martins-stuff

Modified Makefile from [e6e63de436] to [9c85f9cd01].

︙
17
18
19
20
21
22
23
24

25
26
27
28



29
30
31
32




33
34
35
36
37



38
39
40
41
42
43

44


45
46
47
48
49


50



51
52
53




54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76


77
78


79
80
81
82
83
84


85
86
87
88
89
90
91

17
18
19
20
21
22
23

24




25
26
27




28
29
30
31
32
33



34
35
36





37
38

39
40
41
42
43
44
45
46
47
48
49
50
51



52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67



68
69
70
71
72
73
74
75
76
77


78
79
80
81
82
83


84
85
86
87
88
89
90
91
92








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


-
-
-
+
+
+
-
-
-
-
-

+
-
+
+





+
+

+
+
+
-
-
-
+
+
+
+












-
-
-








+
+
-
-
+
+




-
-
+
+









# make install CSCOPTS='-accumulate-profile -profile-name $(PWD)/profile-ww$(shell date +%V.%u)'
# rm <files>.o ; make install CSCOPTS='-profile' ; ... ;  chicken-profile | less
SHELL=/bin/bash
PREFIX=$(PWD)
CSCOPTS=
INSTALL=install
SRCFILES = common.scm items.scm launch.scm \
SRCFILES = common.scm items.scm launch.scm ods.scm runconfig.scm	\
   ods.scm runconfig.scm server.scm configf.scm \
   db.scm keys.scm margs.scm megatest-version.scm \
   process.scm runs.scm tasks.scm tests.scm genexample.scm \
   http-transport.scm filedb.scm tdb.scm \
           server.scm configf.scm db.scm keys.scm margs.scm		\
           megatest-version.scm process.scm runs.scm tasks.scm		\
           tests.scm genexample.scm http-transport.scm filedb.scm	\
   client.scm mt.scm \
   ezsteps.scm lock-queue.scm sdb.scm \
   rmt.scm api.scm subrun.scm \
   portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm 
           tdb.scm client.scm mt.scm ezsteps.scm lock-queue.scm		\
           sdb.scm rmt.scm api.scm subrun.scm portlogger.scm		\
           archive.scm env.scm diff-report.scm				\
           cgisetup/models/pgdb.scm

# module source files
MSRCFILES = ftail.scm rmtmod.scm commonmod.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
# Eggs to install (straightforward ones)
EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \
dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \
json md5 awful http-client spiffy uri-common intarweb spiffy-request-vars \
spiffy-directory-listing ssax sxml-serializer sxml-modifications iup canvas-draw sqlite3

GUISRCF = dashboard-context-menu.scm dashboard-tests.scm		\
GUISRCF  = dashboard-context-menu.scm dashboard-tests.scm dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm vg.scm
          dashboard-guimonitor.scm gutils.scm dcommon.scm tree.scm	\
          vg.scm

OFILES   = $(SRCFILES:%.scm=%.o)
GOFILES  = $(GUISRCF:%.scm=%.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

mofiles/%.o : %.scm
	mkdir -p mofiles
	csc $(CSCOPTS) -J -c $< -o mofiles/$*.o
mofiles/%.o  %.import.scm : %.scm
	@[ -e mofiles ] || mkdir -p mofiles
	csc $(CSCOPTS) -I $* -J -c $< -o mofiles/$*.o
	@touch $*.import.scm # ensure it is touched after the .o is made

ADTLSCR=mt_laststep mt_runstep mt_ezstep
HELPERS=$(addprefix $(PREFIX)/bin/,$(ADTLSCR))
DEPLOYHELPERS=$(addprefix deploytarg/,$(ADTLSCR))
MTESTHASH=$(shell fossil info|grep checkout:| awk '{print $$2}')

ifeq ($(MTESTHASH),)
$(error MTESTHASH is broken!)
endif

CSIPATH=$(shell which csi)
CKPATH=$(shell dirname $(shell dirname $(CSIPATH)))
# ARCHSTR=$(shell uname -m)_$(shell uname -r)
# BASH_MACHTYPE=$(shell bash -c "echo \$$MACHTYPE")
# ARCHSTR=$(BASH_MACHTYPE)_$(shell lsb_release -sr)
ARCHSTR=$(shell if [[ -e /usr/bin/sw_vers ]]; then /usr/bin/sw_vers -productVersion; else lsb_release -sr; fi)
# ARCHSTR=$(shell bash -c "echo \$$MACHTYPE")

PNGFILES = $(shell cd docs/manual;ls *png)

#all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut ndboard
all : $(PREFIX)/bin/.$(ARCHSTR) mtest dboard mtut tcmt

# megatest.o : ducttape-lib.import.o

mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) mofiles/ftail.o mofiles/rmtmod.o mofiles/commonmod.o
	csc $(CSCOPTS) $(OFILES) $(MOFILES) megatest.o -o mtest
mtest: $(OFILES) readline-fix.scm megatest.o $(MOFILES) $(MOIMPFILES)
	csc $(CSCOPTS) $(OFILES) $(MOFILES) $(MOIMPFILES) megatest.o -o mtest

showmtesthash:
	@echo $(MTESTHASH)

dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES)
	csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) -o dboard
dboard : $(OFILES) $(GOFILES) dashboard.scm $(MOFILES) $(MOIMPFILES)
	csc $(CSCOPTS) $(OFILES) dashboard.scm $(GOFILES) $(MOFILES) $(MOIMPFILES) -o dboard

ndboard : newdashboard.scm $(OFILES) $(GOFILES)
	csc $(CSCOPTS) $(OFILES) $(GOFILES) newdashboard.scm -o ndboard

mtut: $(OFILES) $(MOFILES) megatest-fossil-hash.scm mtut.scm
	csc $(CSCOPTS) $(OFILES) $(MOFILES) mtut.scm -o mtut
︙
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123

124

125
126
127

128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146

147
148
149


150
151
152

153
154
155



156

157

158

159

160

161

162




163

164
165
166











167
168
169

170
171
172
173
174
175
176


177
178



















179
180
181
182
183
184
185

109
110
111
112
113
114
115

116
117
118
119
120
121
122

123
124
125
126
127

128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146

147



148
149



150



151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173


174
175
176
177
178
179
180
181
182
183
184
185
186

187
188
189
190
191
192
193
194
195
196


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








-







-
+

+


-
+


















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

+

+

+

+

+

+

+
+
+
+

+

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


-
+







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








	mt.o \
	megatest-version.o \
	ods.o \
	portlogger.o \
	process.o \
	rmt.o \
        mofiles/rmtmod.o \
        mofiles/commonmod.o \
        rpc-transport.o \
	runconfig.o \
	runs.o \
	server.o \
	tasks.o \
	tdb.o \
	tests.o \
	subrun.o \
	subrun.o

#        mofiles/commonmod.o \

tcmt : $(TCMTOBJS) tcmt.scm
	csc $(CSCOPTS) $(TCMTOBJS) tcmt.scm -o tcmt
	csc $(CSCOPTS) $(TCMTOBJS) $(MOFILES) $(MOIMPFILES) tcmt.scm -o tcmt

# install documentation to $(PREFIX)/docs
# DOES NOT REBUILD DOCS
#
$(PREFIX)/share/docs/megatest_manual.html : docs/manual/megatest_manual.html
	mkdir -p $(PREFIX)/share/docs
	$(INSTALL) docs/manual/megatest_manual.html $(PREFIX)/share/docs/megatest_manual.html
	for png in $(PNGFILES);do $(INSTALL) docs/manual/$$png $(PREFIX)/share/docs/$$png;done

# add a fake dependency so this doens't copy everytime
$(PREFIX)/share/js/jquery-3.1.0.slim.min.js : # .fslckout
	mkdir -p $(PREFIX)/share/js
	fossil wiki export java-script-lib > $(PREFIX)/share/js/jquery-3.1.0.slim.min.js

$(PREFIX)/share/db/mt-pg.sql : mt-pg.sql
	mkdir -p $(PREFIX)/share/db
	$(INSTALL) mt-pg.sql $(PREFIX)/share/db/mt-pg.sql

#multi-dboard : multi-dboard.scm $(OFILES) $(GOFILES)
# Special dependencies for the includes
#	csc $(CSCOPTS) $(OFILES) $(GOFILES) multi-dboard.scm -o multi-dboard

# 
common.o : mofiles/commonmod.o

# $(PREFIX)/bin/revtagfsl : utils/revtagfsl.scm
#	csc utils/revtagfsl.scm -o $(PREFIX)/bin/revtagfsl

tests.o db.o launch.o runs.o dashboard-tests.o				\
# Special dependencies for the includes
tests.o db.o launch.o runs.o dashboard-tests.o dashboard-context-menu.o dashboard-guimonitor.o dashboard-main.o monitor.o dashboard.o  \
archive.o megatest.o : db_records.scm
dashboard-context-menu.o dashboard-guimonitor.o dashboard-main.o	\
monitor.o dashboard.o archive.o megatest.o : db_records.scm

tests.o runs.o dashboard.o dashboard-tests.o dashboard-context-menu.o dashboard-main.o  : run_records.scm

db.o ezsteps.o keys.o launch.o megatest.o monitor.o runs-for-ref.o runs.o tests.o : key_records.scm

tests.o tasks.o dashboard-tasks.o : task_records.scm

runs.o : test_records.scm

megatest.o : megatest-fossil-hash.scm

rmt.scm client.scm common.scm configf.scm dashboard-guimonitor.scm dashboard-tests.scm dashboard.scm db.scm dcommon.scm ezsteps.scm fs-transport.scm http-transport.scm index-tree.scm items.scm keys.scm launch.scm megatest.scm monitor.scm mt.scm newdashboard.scm runconfig.scm runs.scm server.scm tdb.scm tests.scm tree.scm : common_records.scm

common_records.scm : altdb.scm

mofiles/stml2.o : mofiles/cookie.o
configf.o : mofiles/commonmod.o

vg.o dashboard.o : vg_records.scm

dcommon.o : run_records.scm
# Temporary while transitioning to new routine
# runs.o : run-tests-queue-classic.scm  run-tests-queue-new.scm

mofiles/stml2.o : mofiles/cookie.o

# special include based modules
mofiles/pkts.o      : pkts/pkts.scm
# mofiles/mtargs.o    : mtargs/mtargs.scm
# mofiles/mtconfigf.o : mtconfigf/mtconfigf.scm
# mofiles/ulex.o      : ulex/ulex.scm
mofiles/mutils.o    : mutils/mutils.scm
mofiles/cookie.o    : stml2/cookie.scm
mofiles/stml2.o     : stml2/stml2.scm

# for the modularized stuff
mofiles/rmtmod.o : mofiles/commonmod.o
rmt.o : mofiles/ducttape-lib.o mofiles/pkts.o mofiles/stml2.o mofiles/mutils.o mofiles/mtargs.o

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 

# This having the full list of MOFILES cause everything to be rebuilt every time.
#
%.o : %.scm $(MOFILES)
	csc $(CSCOPTS) -c $< $(MOFILES)
# %.o : %.scm $(MOFILES)
# 	csc $(CSCOPTS) -c $< $(MOFILES)
#
%.o : %.scm
	csc $(CSCOPTS) -c $<

# specific rules for .o files that genuninely depend on mofiles/something
#
megatest.o : megatest.scm stml2.o mutils.o commonmod.o
	csc $(CSCOPTS) -c megatest.scm stml2.o mutils.o commonmod.o

dashboard.o : dashboard.scm stml2.o mutils.o commonmod.o dbmod.o
	csc $(CSCOPTS) -c megatest.scm stml2.o mutils.o commonmod.o dbmod.o

common.o : megatest.scm mofiles/commonmod.o common.scm
	csc $(CSCOPTS) -c common.scm mofiles/commonmod.o

configf.o : configf.scm mofiles/commonmod.o
	csc $(CSCOPTS) -c configf.scm mofiles/commonmod.o

$(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
︙
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243

256
257
258
259
260
261
262











263
264
265
266
267
268
269








-
-
-
-
-
-
-
-
-
-
-








$(PREFIX)/bin/.$(ARCHSTR)/tcmt : tcmt
	$(INSTALL) tcmt $(PREFIX)/bin/.$(ARCHSTR)/tcmt

$(PREFIX)/bin/tcmt : $(PREFIX)/bin/.$(ARCHSTR)/tcmt utils/mk_wrapper
	utils/mk_wrapper $(PREFIX) tcmt $(PREFIX)/bin/tcmt
	chmod a+x $(PREFIX)/bin/tcmt

# $(PREFIX)/bin/.$(ARCHSTR)/mdboard : multi-dboard
#	$(INSTALL) multi-dboard $(PREFIX)/bin/.$(ARCHSTR)/mdboard

# $(PREFIX)/bin/mdboard : $(PREFIX)/bin/.$(ARCHSTR)/mdboard  utils/mk_wrapper
# 	utils/mk_wrapper $(PREFIX) mdboard $(PREFIX)/bin/mdboard
# 	chmod a+x $(PREFIX)/bin/mdboard

# $(HELPERS) : utils/%
# 	$(INSTALL) $< $@
# 	chmod a+x $@

$(PREFIX)/bin/mt_laststep : utils/mt_laststep
	$(INSTALL) $< $@
	chmod a+x $@

$(PREFIX)/bin/mt_runstep : utils/mt_runstep
	$(INSTALL) $< $@
	chmod a+x $@
︙
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287

296
297
298
299
300
301
302




303
304
305
306
307
308
309








-
-
-
-








	$(INSTALL) $< $@
	chmod a+x $@

$(PREFIX)/bin/mtrunner : utils/mtrunner
	$(INSTALL) $< $@
	chmod a+x $@

# $(PREFIX)/bin/refdb : refdb
# 	$(INSTALL) $< $@
# 	chmod a+x $@

deploytarg/nbfake : utils/nbfake
	$(INSTALL) $< $@
	chmod a+x $@

deploytarg/viewscreen : utils/viewscreen
	$(INSTALL) $< $@
	chmod a+x $@
︙
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333



334
335


336
337
338
339



340
341
342
343








344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383

327
328
329
330
331
332
333



334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349



350
351
352


353
354




355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377






378
379






380
381
382
383
384
385
386
387
388


389
390
391
392
393
394
395








-
-
-
















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




+
+
+
+
+
+
+
+








-
-
-
-
-
-


-
-
-
-
-
-









-
-








          $(PREFIX)/bin/.$(ARCHSTR)/dboard $(PREFIX)/bin/dashboard $(HELPERS) $(PREFIX)/bin/nbfake \
          $(PREFIX)/bin/.$(ARCHSTR)/mtexec $(PREFIX)/bin/mtexec $(PREFIX)/bin/serialize-env \
	  $(PREFIX)/bin/nbfind $(PREFIX)/bin/mtrunner $(PREFIX)/bin/viewscreen $(PREFIX)/bin/mt_xterm \
	  $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun \
	  $(PREFIX)/share/docs/megatest_manual.html $(PREFIX)/bin/remrun $(PREFIX)/bin/mtutil \
	  $(PREFIX)/bin/tcmt $(PREFIX)/share/db/mt-pg.sql \
          $(PREFIX)/share/js/jquery-3.1.0.slim.min.js 
#         $(PREFIX)/bin/.$(ARCHSTR)/ndboard

# $(PREFIX)/bin/newdashboard

$(PREFIX)/bin/.$(ARCHSTR) : 
	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)
	mkdir -p $(PREFIX)/bin/.$(ARCHSTR)/lib

test: tests/tests.scm
	cd tests;csi -I .. -b -n tests.scm

ext-tests/.fslckout : $(MTQA_FOSSIL)
	mkdir -p ext-tests
	cd ext-tests;fossil open --nested $(MTQA_FOSSIL)

$(MTQA_FOSSIL) :
	fossil clone https://www.kiatoa.com/fossils/megatest_qa $(MTQA_FOSSIL)

clean : 
	rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS) $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil mtut tcmt ftail.import.scm readline-fix.scm serialize-env dboard dboard.o megatest.o dashboard.o megatest-fossil-hash.* altdb.scm mofiles/*.o vg.o
	rm -rf share

	rm -f $(OFILES) $(GOFILES) $(MOFILES) $(TCMTOBJS)		\
            $(PREFIX)/megatest $(PREFIX)/dashboard mtest mtutil mtut	\
            tcmt readline-fix.scm serialize-env dboard dboard.o		\
#======================================================================
# Make the records files
            megatest.o dashboard.o megatest-fossil-hash.* altdb.scm	\
            mofiles/*.o vg.o cookie.o dashboard-main.o	\
#======================================================================

# vg_records.scm : records.sh
#	./records.sh
            ducttape-lib.o ftail.o mutils.o pkts.o rmtmod.o stml2.o	\
            tcmt.o
	rm -rf share

#======================================================================
# Deploy section (not complete yet)
#======================================================================

# Eggs to install (straightforward ones)
EGGS=matchable readline aokpropos base64 regex-literals format		\
regex-case test coops trace csv dot-locking posix-utils posix-extras	\
directory-utils hostinfo tcp-server rpc csv-xml fmt json md5 awful	\
http-client spiffy uri-common intarweb spiffy-request-vars		\
spiffy-directory-listing ssax sxml-serializer sxml-modifications iup	\
canvas-draw sqlite3

$(DEPLOYHELPERS) : utils/mt_*
	$(INSTALL) $< $@
	chmod a+X $@

deploytarg/apropos.so : Makefile
	chicken-install -p deploytarg -deploy -keep-installed $(EGGS)

#	for i in apropos base64 canvas-draw csv-xml directory-utils dot-locking extras fmt format hostinfo http-client intarweb json md5 message-digest posix posix-extras readline regex regex-case s11n spiffy spiffy-request-vars sqlite3 srfi-1 srfi-18 srfi-69 tcp test uri-common check-errors synch matchable sql-null tcp-server rpc blob-utils string-utils variable-item defstruct uri-generic sendfile opensll openssl lookup-table list-utils stack; do \
#	chicken-install -prefix deploytarg -deploy $$i;done

# deploytarg/libsqlite3.so : 
# 	CSC_OPTIONS="-Ideploytarg -Ldeploytarg" $CHICKEN_INSTALL -prefix deploytarg -deploy sqlite3

deploy : deploytarg/mtest deploytarg/dboard $(DEPLOYHELPERS) deploytarg/nbfake deploytarg/remrun deploytarg/viewsceen deploytarg/nbfind deploytarg/apropos.so

# deploytarg/libiupcd.so : $(CKPATH)/lib/libiupcd.so
# 	for i in iup im cd av call sqlite; do \
# 	  cp $(CKPATH)/lib/lib$$i* deploytarg/ ; \
# 	done
# 	cp $(CKPATH)/include/*.h deploytarg

# puts deployed megatest in directory "megatest"
deploytarg/mtest : $(OFILES) megatest.o deploytarg/apropos.so
	csc -deploy $(CSCOPTS) $(OFILES) megatest.scm -o deploytarg
	mv deploytarg/deploytarg deploytarg/mtest

deploytarg/dboard :  $(OFILES) $(GOFILES) dashboard.scm deploytarg/apropos.so
	csc -deploy $(OFILES) $(GOFILES) dashboard.scm -o deploytarg
	mv deploytarg/deploytarg deploytarg/dboard

# DATASHAREO=configf.o common.o process.o tree.o dcommon.o margs.o launch.o gutils.o db.o synchash.o server.o \
#            megatest-version.o tdb.o ods.o mt.o keys.o
datashare-testing/sd : datashare.scm $(OFILES)
	csc $(CSCOPTS) datashare.scm $(OFILES) -o datashare-testing/sd

datashare-testing/sdat: sharedat.scm $(OFILES)
	csc $(CSCOPTS) sharedat.scm $(OFILES) -o datashare-testing/sdat

sd : datashare-testing/sd
︙
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453

















































































412
413
414
415
416
417
418







419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435







436
437
438




439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527








-
-
-
-
-
-
-

















-
-
-
-
-
-
-



-
-
-
-









+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

	mkdir -p  datashare-testing
	rm  datashare-testing/sauthorize
	rm  datashare-testing/sretrieve 
	rm  datashare-testing/spublish

sauth : sauth-init datashare-testing/sauthorize datashare-testing/sretrieve datashare-testing/spublish 


# base64 dot-locking \
#             csv-xml z3

#  "(define (toplevel-command . a) #f)"
# if egrep 'version.*3.0' $(shell dirname $(shell dirname $(shell which csi)))/lib/chicken/7/readline.setup-info;then \

readline-fix.scm :
	if [[ $(shell chicken-status | grep readline | awk '{print $4}' | cut -d. -f1) -gt 3 ]];then \
	   echo "(define *use-new-readline* #f)" > readline-fix.scm; \
	else \
	   echo "(define *use-new-readline* #t)" > readline-fix.scm;\
	fi

altdb.scm :
	echo ";; optional alternate db setup" > altdb.scm
	echo "(define *available-db* (make-hash-table))" >> altdb.scm
	if  csi -ne '(use mysql-client)';then \
           echo "(use mysql-client)(hash-table-set! *available-db* 'mysql #t)" >> altdb.scm; \
	fi
	if csi -ne '(use postgresql)';then \
	   echo "(use postgresql)(hash-table-set! *available-db* 'postgresql #t)" >> altdb.scm;\
	fi

portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
	csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o

# create a pdf dot graphviz diagram from notations in rmt.scm
rmt.pdf : rmt.scm
	grep ';;DOT' rmt.scm | sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf

buildmanual:
	cd docs/manual && make

wikipage=plan
editwiki:
	cd docs/manual && ../../utils/editwiki $(wikipage)

viewmanual:
	arora docs/manual/megatest_manual.html

targets:
	@grep : Makefile | perl -ne '/^([A-Za-z0-9_-]+):/ && print "$$1\n"'


unit :
	cd tests;make unit

#======================================================================
# Chicken build
#======================================================================

tgz/chicken-4.13.0.tar.gz :
	mkdir -p tgz
	curl https://code.call-cc.org/releases/4.13.0/chicken-4.13.0.tar.gz > tgz/chicken-4.13.0.tar.gz

build/chicken-4.13.0/LICENSE : tgz/chicken-4.13.0.tar.gz
	mkdir -p build/eggs-installed
	cd build;tar xf ../tgz/chicken-4.13.0.tar.gz

build/bin/csi : build/chicken-4.13.0/LICENSE
	cd build/chicken-4.13.0;make PLATFORM=linux
	cd build/chicken-4.13.0;make PLATFORM=linux PREFIX=../ install

EGGS=srfi-69
EGGSTARG=$(addsuffix .done,$(addprefix build/eggs-installed/,$(EGGS)))

build/eggs-installed/%.done : build/bin/csi
	build/bin/chicken-install $* > build/eggs-installed/$*.done

#======================================================================
# Attic
#======================================================================

# portlogger-example : portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o
#	csc $(CSCOPTS) portlogger-example.scm api.o archive.o client.o common.o configf.o dashboard-tests.o dashboard-context-menu.o db.o dcommon.o ezsteps.o filedb.o genexample.o gutils.o http-transport.o items.o keys.o launch.o lock-queue.o margs.o megatest-version.o mt.o ods.o portlogger.o process.o rmt.o rpc-transport.o runconfig.o runs.o sdb.o server.o synchash.o tasks.o tdb.o tests.o tree.o

# create a pdf dot graphviz diagram from notations in rmt.scm
# rmt.pdf : rmt.scm
#	grep ';;DOT' rmt.scm | sed -e 's/.*;;DOT //' > rmt.dot;dot -Tpdf rmt.dot -o rmt.pdf

# wikipage=plan
# editwiki:
#	cd docs/manual && ../../utils/editwiki $(wikipage)

# base64 dot-locking \
#             csv-xml z3

#  "(define (toplevel-command . a) #f)"
# if egrep 'version.*3.0' $(shell dirname $(shell dirname $(shell which csi)))/lib/chicken/7/readline.setup-info;then \

# DATASHAREO=configf.o common.o process.o tree.o dcommon.o margs.o launch.o gutils.o db.o synchash.o server.o \
#            megatest-version.o tdb.o ods.o mt.o keys.o

# deploytarg/libiupcd.so : $(CKPATH)/lib/libiupcd.so
# 	for i in iup im cd av call sqlite; do \
# 	  cp $(CKPATH)/lib/lib$$i* deploytarg/ ; \
# 	done
# 	cp $(CKPATH)/include/*.h deploytarg

#	for i in apropos base64 canvas-draw csv-xml directory-utils dot-locking extras fmt format hostinfo http-client intarweb json md5 message-digest posix posix-extras readline regex regex-case s11n spiffy spiffy-request-vars sqlite3 srfi-1 srfi-18 srfi-69 tcp test uri-common check-errors synch matchable sql-null tcp-server rpc blob-utils string-utils variable-item defstruct uri-generic sendfile opensll openssl lookup-table list-utils stack; do \
#	chicken-install -prefix deploytarg -deploy $$i;done

# deploytarg/libsqlite3.so : 
# 	CSC_OPTIONS="-Ideploytarg -Ldeploytarg" $CHICKEN_INSTALL -prefix deploytarg -deploy sqlite3

#======================================================================
# Make the records files
#======================================================================

# vg_records.scm : records.sh
#	./records.sh

# $(PREFIX)/bin/.$(ARCHSTR)/mdboard : multi-dboard
#	$(INSTALL) multi-dboard $(PREFIX)/bin/.$(ARCHSTR)/mdboard

# $(PREFIX)/bin/mdboard : $(PREFIX)/bin/.$(ARCHSTR)/mdboard  utils/mk_wrapper
# 	utils/mk_wrapper $(PREFIX) mdboard $(PREFIX)/bin/mdboard
# 	chmod a+x $(PREFIX)/bin/mdboard

# $(HELPERS) : utils/%
# 	$(INSTALL) $< $@
# 	chmod a+x $@

# ARCHSTR=$(shell uname -m)_$(shell uname -r)
# BASH_MACHTYPE=$(shell bash -c "echo \$$MACHTYPE")
# ARCHSTR=$(BASH_MACHTYPE)_$(shell lsb_release -sr)

Modified TODO from [e0a2376de1] to [23e18762ef].

︙
11
12
13
14
15
16
17



18
19
20


21





22









23
















24
25
26
27
28
29
30
31
32
33
34

11
12
13
14
15
16
17
18
19
20
21
22
23
24
25

26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64

65

66








+
+
+



+
+
-
+
+
+
+
+

+
+
+
+
+
+
+
+
+

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







-

-


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

NOTE: This file gets copied occasionally into the wiki as "Roadmap".
      Do not make changes in the wiki, they will be lost!

TODO
====

WW14
. Streamline compilation - DONE, all non-official egg modules are now bundled.
. Dashboard should resist running from non-homehost

WW15
. syscheck; touch file in home, tmp, runs, links and start xterm
. fill newview matrix with data, filter pipeline gui elements
. improve [script], especially indent handling

WW16
. split db into megatest.db (runs etc.) db/<something>.db
. release basic newview implementation
. archiving improvements/extentions
.. -get-data, -put-data
.. use MT_ vars if defined and no switch present
.. fix archive "first run" bug
.. areas path1 path2 ... -> search path for archives
.. -propagate -> move archive data forward when it is found in older bundles

WW18
. release split db implementation
. mtutil calls from dashboard (for remote control)
. logs browser (esp. for surfacing mtutil related activities)

WW19
. break command line into sections; all, run control, queries, utilities etc.
. pull in ftfplan (not integrated, just code pulled in)

WW20
. Switch to using simple runs query everywhere
. Add end_time to runs and add a rollup call that sets state, status and end_time

Future
. Switch to scsh-process pipeline management for job execution/control
. Use call-with-environment-variables more.

Migration to inmem db plus per run db
-------------------------------------

. Re-work the dbstruct data structure?
.. Move main.db to global?
.. [ run-id.db inmemdb last-mod last-read last-sync inuse ]
. Re-work all queries to use run-id to dereference server
. Open main.db directly in calls to -runtests etc. No need to talk remote?
. remove common:faux-lock

Modified api.scm from [a15c0cd809] to [8a3eb8aa72].

︙
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








+








    get-run-times
    get-targets
    get-target
    ;; register-run
    get-tests-tags
    get-test-times
    get-tests-for-run
    get-tests-for-run-state-status
    get-test-id
    get-tests-for-runs-mindata
    get-tests-for-run-mindata
    get-run-name-from-id
    get-runs
    simple-get-runs
    get-num-runs
︙
290
291
292
293
294
295
296

297
298
299
300
301
302
303

291
292
293
294
295
296
297
298
299
300
301
302
303
304
305








+








                   ;; RUNS
                   ((get-run-info)                 (apply db:get-run-info dbstruct params))
                   ((get-run-status)               (apply db:get-run-status dbstruct params))
                   ((get-run-state)                (apply db:get-run-state dbstruct params))
                   ((set-run-status)               (apply db:set-run-status dbstruct params))
                   ((set-run-state-status)  			 (apply db:set-run-state-status dbstruct params))
                   ((get-tests-for-run)            (apply db:get-tests-for-run dbstruct params))
                   ((get-tests-for-run-state-status) (apply db:get-tests-for-run-state-status dbstruct params))
                   ((get-test-id)                  (apply db:get-test-id dbstruct params))
                   ((get-tests-for-run-mindata)    (apply db:get-tests-for-run-mindata dbstruct params))
                   ;; ((get-tests-for-runs-mindata)   (apply db:get-tests-for-runs-mindata dbstruct params))
                   ((get-runs)                     (apply db:get-runs dbstruct params))
                   ((simple-get-runs)              (apply db:simple-get-runs dbstruct params))
                   ((get-num-runs)                 (apply db:get-num-runs dbstruct params))
                   ((get-runs-cnt-by-patt)         (apply db:get-runs-cnt-by-patt dbstruct params))
︙

Modified archive.scm from [618f9a591e] to [bb0fd0a689].

︙
384
385
386
387
388
389
390
391















































384
385
386
387
388
389
390

391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436








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

		 (debug:print-info 0 *default-log-port* "Restoring archived data to " new-test-physical-path " from archive in " archive-path " ... " archive-internal-path)
		 ;; (mutex-lock! bup-mutex)
		 (run-n-wait bup-exe params: bup-restore-params print-cmd: #f)
		 ;; (mutex-unlock! bup-mutex)
		 (mt:test-set-state-status-by-id run-id test-id "COMPLETED" #f #f)))
	     (debug:print-error 0 *default-log-port* "No archive path in the record for run-id=" run-id " test-id=" test-id))))
     (filter vector? tests))))
	 

;; from an archive get a specific path - works ONLY with bup for now
;;
(define (archive:bup-get-data archive-command run-id run-name tests rp-mutex bup-mutex)
  (if (null? tests)
      (debug:print-info 0 *default-log-port* "get-data called with no matching tests to operate on.")
      (let* ((bup-exe      (or (configf:lookup *configdat* "archive" "bup") "bup"))
	     (linktree     (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")))
	     (test-dat     (car tests))
	     (destpath     (args:get-arg "-dest")))

	;; When restoring test-dat will initially contain an old and invalid path to the test
	(let* ((item-path         (db:test-get-item-path test-dat))
	       (test-name         (db:test-get-testname  test-dat))
	       (test-id           (db:test-get-id        test-dat))
	       (run-id            (db:test-get-run_id    test-dat))
	       (keyvals           (rmt:get-key-val-pairs run-id))
	       (target            (string-intersperse (map cadr keyvals) "/"))
	       
	       (toplevel/children (and (db:test-get-is-toplevel test-dat)
				       (> (rmt:test-toplevel-num-items run-id test-name) 0)))
	       (test-partial-path (conc target "/" run-name "/" (db:test-make-full-name test-name item-path)))
	       ;; note the trailing slash to get the dir inspite of it being a link
	       (test-path         (conc linktree "/" test-partial-path))
	       (mutex-lock! rp-mutex)
	       (mutex-unlock! rp-mutex)
	       (archive-block-id        (db:test-get-archived test-dat))
	       (archive-block-info      (rmt:test-get-archive-block-info archive-block-id))
	       (archive-path            (if (vector? archive-block-info)
					    (vector-ref archive-block-info 2) ;; look in db.scm for test-get-archive-block-info for the vector record info
					    #f)) ;; no archive found?
	       (archive-internal-path   (conc (common:get-testsuite-name) "-" run-id "/latest/" test-partial-path)))
	  
	  (if (and archive-path ;; no point in proceeding if there is no actual archive
		   (not toplevel/children))
	      (begin
		;; bup -d /tmp/matt/adisk1/2015_q1/fullrun_e1a40/ restore -C /tmp/seeme fullrun-30/latest/ubuntu/nfs/none/w02.1.20.54_b/
		
		;; DO BUP RESTORE
		(let* (;; new-test-path won't work - must use best-disk instead? Nope, new-test-path but tack on /..
		       (bup-restore-params  (list "-d" archive-path "restore" "-C" (or destpath "data") " " archive-internal-path)))
		  (debug:print-info 0 *default-log-port* "Restoring archived data to " (or destpath "data") " from archive in " archive-path " ... " archive-internal-path)
		  ;; (mutex-lock! bup-mutex)
		  (run-n-wait bup-exe params: bup-restore-params print-cmd: #f)))
	      (debug:print-error 0 *default-log-port* "No archive path in the record for run-id=" run-id " test-id=" test-id))))))

Modified common.scm from [4d4a2441c8] to [17bee313ac].

︙
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








-
+

-
+




+
+
-
+









;;======================================================================

(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 nanomsg nmsg:)
     (prefix sqlite3 sqlite3:)
     pkts (prefix dbi dbi:)
     (prefix dbi dbi:)
     )

(declare (unit common))
(declare (uses commonmod))
(import (prefix commonmod cmod:))

(import commonmod)
(import pkts)

(include "common_records.scm")


;; (require-library margs)
;; (include "margs.scm")
︙
871
872
873
874
875
876
877
878
879
880
881

882
883
884
885
886
887
888
889
890

873
874
875
876
877
878
879




880


881
882
883
884
885
886
887








-
-
-
-
+
-
-








    (if val val default)))

(define (assoc/default key lst . default)
  (let ((res (assoc key lst)))
    (if res (cadr res)(if (null? default) #f (car default)))))

(define (common:get-testsuite-name)
  (or (configf:lookup *configdat* "setup" "area-name") ;; megatest is a flexible tool, testsuite is too limiting a description.
      (configf:lookup *configdat* "setup" "testsuite" )
      (getenv "MT_TESTSUITE_NAME")
      (if (string? *toppath* )
  (cmod:get-testsuite-name *toppath* *configdat*))
          (pathname-file *toppath*)
          #f))) ;; (pathname-file (current-directory)))))

;; safe getting of toppath
(define (common:get-toppath areapath)
  (or *toppath*
      (if areapath
	  (begin
	    (set! *toppath* areapath)
︙
1614
1615
1616
1617
1618
1619
1620
1621
1622

1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636

1637
1638
1639
1640
1641
1642
1643
1644
1645
1646

1611
1612
1613
1614
1615
1616
1617


1618
1619
1620
1621
1622
1623









1624



1625
1626
1627
1628
1629
1630
1631








-
-
+





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








		    (if (> curr-rownum rownum) curr-rownum rownum)
		    (if (> curr-colnum colnum) curr-colnum colnum)
		    ))))))

;; if it looks like a number -> convert it to a number, else return it
;;
(define (common:lazy-convert inval)
  (let* ((as-num (if (string? inval)(string->number inval) #f)))
    (or as-num inval)))
  (cmod:lazy-convert inval))

;; convert string a=1; b=2; c=a silly thing; d=
;; to '((a . 1)(b . 2)(c . "a silly thing")(d . ""))
;;
(define (common:val->alist val #!key (convert #f))
  (let ((val-list (string-split-fields ";\\s*" val #:infix)))
    (if val-list
	(map (lambda (x)
	       (let ((f (string-split-fields "\\s*=\\s*" x #:infix)))
		 (case (length f)
		   ((0) `(,#f))  ;; null string case
		   ((1) `(,(string->symbol (car f))))
		   ((2) `(,(string->symbol (car f)) . ,(let ((inval (cadr f)))
							 (if convert (common:lazy-convert inval) inval))))
  (cmod:val->alist val #!key (convert #f)))
		   (else f))))
	     val-list)
	'())))

;;======================================================================
;; S Y S T E M   S T U F F
;;======================================================================

;; lazy-safe get file mod time. on any error (file not existing etc.) return 0
;;
︙
1730
1731
1732
1733
1734
1735
1736
1737









1738
1739
1740
1741
1742
1743
1744

1715
1716
1717
1718
1719
1720
1721

1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737








-
+
+
+
+
+
+
+
+
+








	     (fullpath (conc fulldir "/" key "-" dtype ".log")))
	(if (not (file-exists? fulldir))(create-directory fulldir #t))
	(handle-exceptions
	 exn
	 #f
	 (with-output-to-file fullpath (lambda ()(pp dat)))))
      #f))
  

(define (common:raw-get-remote-host-load remote-host)
  (handle-exceptions
   exn
   #f ;; more specific handling of errors needed
   (with-input-from-pipe 
    (conc "ssh " remote-host " cat /proc/loadavg")
    (lambda ()(list (read)(read)(read))))))

;; get cpu load by reading from /proc/loadavg, return all three values
;;
(define (common:get-cpu-load remote-host)
  (handle-exceptions
   exn
   '(99 99 99)
   (let* ((actual-hostname (or remote-host (get-host-name) "localhost")))
︙

Modified commonmod.scm from [c7972f9b4b] to [3a4a140a66].

︙
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
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151








-
-
+
+
+
+

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








;;======================================================================

(declare (unit commonmod))

(module commonmod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)
(import scheme chicken data-structures extras files)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18 srfi-69
	md5 message-digest
	regex srfi-1)

;;======================================================================
;; CONTENTS
;;
;;  config file utils
;;  misc conversion, data manipulation functions
;;  testsuite and area utilites
;;
;;======================================================================

;;======================================================================
;; config file utils
;;======================================================================

(define (lookup cfgdat section var)
  (if (hash-table? cfgdat)
      (let ((sectdat (hash-table-ref/default cfgdat section '())))
	(if (null? sectdat)
	    #f
	    (let ((match (assoc var sectdat)))
	      (if match ;; (and match (list? match)(> (length match) 1))
		  (cadr match)
		  #f))
	    ))
      #f))

;; returns var key1=val1; key2=val2 ... as alist
(define (get-key-list cfgdat section var)
  ;; convert string a=1; b=2; c=a silly thing; d=
  (let ((valstr (lookup cfgdat section var)))
    (if valstr
	(val->alist valstr)
	'()))) ;; should it return empty list or #f to indicate not set?


(define (get-section cfgdat section)
  (hash-table-ref/default cfgdat section '()))

;;======================================================================
;; misc conversion, data manipulation functions
;;======================================================================

;; if it looks like a number -> convert it to a number, else return it
;;
(define (lazy-convert inval)
  (let* ((as-num (if (string? inval)(string->number inval) #f)))
    (or as-num inval)))

;; to '((a . 1)(b . 2)(c . "a silly thing")(d . ""))
;;
(define (val->alist val #!key (convert #f))
  (let ((val-list (string-split-fields ";\\s*" val #:infix)))
    (if val-list
	(map (lambda (x)
	       (let ((f (string-split-fields "\\s*=\\s*" x #:infix)))
		 (case (length f)
		   ((0) `(,#f))  ;; null string case
		   ((1) `(,(string->symbol (car f))))
		   ((2) `(,(string->symbol (car f)) .
			  ,(let ((inval (cadr f)))
			     (if convert (lazy-convert inval) inval))))
		   (else f))))
	     (filter (lambda (x)
		       (not (string-match "^\\s*" x)))
		     val-list))
	'())))

;;======================================================================
;; testsuite and area utilites
;;======================================================================

(define (get-testsuite-name toppath configdat)
  (or (lookup configdat "setup" "area-name")
      (lookup configdat "setup" "testsuite")
      (get-environment-variable "MT_TESTSUITE_NAME")
      (if (string? toppath)
          (pathname-file toppath)
          #f)))

(define (get-area-path-signature toppath #!optional (short #f))
  (let ((res (message-digest-string (md5-primitive) toppath)))
    (if short
	(substring res 0 4)
	res)))

(define (get-area-name configdat toppath #!optional (short #f))
  ;; look up my area name in areas table (future)
  ;; generate auto name
  (conc (get-area-path-signature toppath short)
	"-"
	(get-testsuite-name toppath configdat)))

;; need generic find-record-with-var-nmatching-val
;;
(define (path->area-record cfgdat path)
  (let* ((areadat (get-cfg-areas cfgdat))
	 (all     (filter (lambda (x)
			    (let* ((keyvals (cdr x))
				   (pth     (alist-ref 'path keyvals)))
			      (equal? path pth)))
			  areadat)))
    (if (null? all)
	#f
	(car all)))) ;; return first match

;; given a config return an alist of alists
;;   area-name => data
;;
(define (get-cfg-areas cfgdat)
  (let ((adat (get-section cfgdat "areas")))
    (map (lambda (entry)
	   `(,(car entry) . 
	     ,(val->alist (cadr entry))))
	 adat)))
	 
;; (define (debug:print . params) #f)
;; (define (debug:print-info . params) #f)
;; 
;; (define (set-functions dbgp dbgpinfo)
;;   (set! debug:print dbgp)
;;   (set! debug:print-info dbgpinfo))
︙

Modified configf.scm from [dfa800e4cf] to [5265dcb17d]. 

1
2
3
4
5
6
7
8
9
10
11
12
13
14

15
16
17
18
19
20
21
22
23
24
25
26
27
28
29



30
31
32
33
34
35
36

1
2
3
4
5
6
7
8
9
10
11
12
13

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














-
+















+
+
+








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

;;======================================================================

;;======================================================================
;; Config file handling
;;======================================================================

(use regex regex-case matchable) ;;  directory-utils)
(declare (unit configf))
(declare (uses process))
(declare (uses env))
(declare (uses keys))
(declare (uses commonmod))

(import (prefix commonmod cmod:))

(include "common_records.scm")

;; return list (path fullpath configname)
(define (find-config configname #!key (toppath #f))
  (if toppath
      (let ((cfname (conc toppath "/" configname)))
︙
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525

526



527
528
529
530
531
532
533

500
501
502
503
504
505
506












507
508
509
510
511
512
513
514
515

516
517
518
519
520
521
522
523
524
525
526
527








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









-
+

+
+
+








    (if toppath (change-directory toppath)) 
    (if (and toppath pathenvvar)(setenv pathenvvar toppath))
    (let ((configdat  (if configfile 
			  (read-config configfile #f #t environ-patt: environ-patt post-section-procs: (list (cons "^fields$" set-fields)) #f))))
      (if toppath (change-directory curr-dir))
      (list configdat toppath configfile fname))))

(define (configf:lookup cfgdat section var)
  (if (hash-table? cfgdat)
      (let ((sectdat (hash-table-ref/default cfgdat section '())))
	(if (null? sectdat)
	    #f
	    (let ((match (assoc var sectdat)))
	      (if match ;; (and match (list? match)(> (length match) 1))
		  (cadr match)
		  #f))
	    ))
      #f))

;; use to have definitive setting:
;;  [foo]
;;  var yes
;;
;;  (configf:var-is? cfgdat "foo" "var" "yes") => #t
;;
(define (configf:var-is? cfgdat section var expected-val)
  (equal? (configf:lookup cfgdat section var) expected-val))

(define config-lookup configf:lookup)
;; (define config-lookup configf:lookup)
(define configf:read-file read-config)

(define (configf:lookup  cfgdat section var)
  (cmod:lookup cfgdat section var))

;; safely look up a value that is expected to be a number, return
;; a default (#f unless provided)
;;
(define (configf:lookup-number cfdat section varname #!key (default #f))
  (let* ((val (configf:lookup *configdat* section varname))
         (res (if val
︙

Added cookie.scm version [93f6026f72]. 

























1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;;======================================================================
;; Copyright 2019, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================

(declare (unit cookie))

(include "stml2/cookie.scm")








Modified dashboard.scm
from [2679042d5f]
to [647f8d5ef7].




︙


21
22
23
24
25
26
27
28

29
30
31
32
33
34
35

21
22
23
24
25
26
27

28
29
30
31
32
33
34
35








-
+








(use format)

(require-library iup)
(import (prefix iup iup:))

(use canvas-draw)
(import canvas-draw-iup)
(use ducttape-lib)
(import ducttape-lib)
(use sqlite3 srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors) ;; defstruct
(import (prefix sqlite3 sqlite3:))

(declare (uses common))
(declare (uses margs))
(declare (uses keys))
(declare (uses items))




︙


45
46
47
48
49
50
51





52
53
54
55
56
57
58

45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63








+
+
+
+
+








(declare (uses dashboard-context-menu))
(declare (uses vg))
(declare (uses subrun))
;; (declare (uses dashboard-main))
(declare (uses megatest-version))
(declare (uses mt))

(declare (uses dbmod))
(import (prefix dbmod dbmod:))
(declare (uses commonmod))
(import (prefix commonmod cmod:))

(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "task_records.scm")
(include "megatest-fossil-hash.scm")
(include "vg_records.scm")





︙


429
430
431
432
433
434
435


































































436
437
438
439
440
441
442

434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513








+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








  ((tests-by-name (make-hash-table)) : hash-table) ;; hash of testfullname => testdat
  key-vals
  ((last-update   0)                 : number)    ;; last query to db got records from before last-update
  ((last-db-time  0)                 : number)    ;; last timestamp on megatest.db
  ((data-changed  #f)                : boolean)   
  ((run-data-offset  0)              : number)      ;; get only 100 items per call, set back to zero when received less than 100 items
  (db-path #f))

;; for the new runs view lets build up a few new record types and then consolidate later
;;
;; this is a two level deep pipeline for the incoming data:
;;   sql query data ==> filters ==> data for display
;;
(defstruct dboard:rdat
  ;; view related items
  (runnum    0) ;; which column we are processing, index into runsbynum, we sweep across all these runs then start over
  (leftcol   0) ;; number of the leftmost visible column
  (toprow    0) ;; topmost visible row
  (numcols  24) ;; number of columns visible
  (numrows  20) ;; number of rows visible
  
  ;; data from sql db
  (keys       (rmt:get-keys))         ;; to be removed when targets handling is refactored
  (runs       (make-sparse-vector))   ;; id => runrec
  (runsbynum  (make-vector 100 #f))   ;; vector num => runrec 
  (targ-runid (make-hash-table))      ;; area/target/runname => run-id  ;; not sure this will be needed
  (tests      (make-hash-table))      ;; test[/itempath] => list of test rec

  ;; run sql filters 
  (targ-sql-filt        "%")
  (runname-sql-filt     "%")
  (run-state-sql-filt   "%")
  (run-status-sql-filt  "%")

  ;; test sql filter
  (testname-sql-filt    "%")
  (itempath-sql-filt    "%")
  (test-state-sql-filt  "%")
  (test-status-sql-filt "%")

  ;; other sql related fields
  (last-updates (make-sparse-vector 0))  ;; run-id -> timestamp of the last update from sql db, set to zero on any field changes

  ;; filtered data
  (cols  (make-sparse-vector))   ;; columnnum => run-id
  (tests (make-hash-table))      ;; test[/itempath] => (vector columnnum => test rec)

  ;; various
  (prev-run-ids  '())            ;; push previously looked at runs on this
  (view-changed #f)

  ;; widgets
  (runs-tree #f)                 ;; 
  )

(define (dboard:rdat-push-run-id rdat run-id)
  (dboard:rdat-prev-run-ids-set! rdat (cons run-id (dboard:rdat-prev-run-ids rdat))))

(defstruct dboard:runrec
  id
  target  ;; a/b/c...
  tdef    ;; for future use
  )
     
(defstruct dboard:testrec
  id
  runid
  testname  ;; test[/itempath]
  state
  status
  start-time
  duration
  )

;; register dboard:rundat with BBpp
;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle
(hash-table-set! *BBpp_custom_expanders_list* RUNDAT:
                 (cons dboard:rundat?
                       (lambda (tabdat-item)
                         (filter




︙


1410
1411
1412
1413
1414
1415
1416
1417

1418
1419
1420
1421
1422
1423
1424

1481
1482
1483
1484
1485
1486
1487

1488
1489
1490
1491
1492
1493
1494
1495








-
+








	 (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas
	 (test-patterns-textbox  #f))
    (hash-table-set! tests-draw-state 'first-time #t)
    ;; (hash-table-set! tests-draw-state 'scalef 1)
    (tests:get-full-data test-names test-records '() all-tests-registry)
    (set! sorted-testnames (tests:sort-by-priority-and-waiton test-records))
    
    ;; refer to (dboard:tabdat-keys tabdat), (dboard:tabdat-dbkeys tabdat) for keys
    ;; refer to (dboard:tabcodat-keys tabdat), (dboard:tabdat-dbkeys tabdat) for keys
    (let* ((result
	    (iup:vbox
	     (dcommon:command-execution-control tabdat)
	     (iup:split
	      #:orientation "VERTICAL" ;; "HORIZONTAL"
	      #:value 200
	      ;; 




︙


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




1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490








1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507

1508

































































1509



1510
1511
1512
1513
1514
1515
1516

1525
1526
1527
1528
1529
1530
1531














1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553

1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566



1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658

1659
1660
1661
1662
1663
1664
1665
1666
1667
1668








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



+
+
-
+
+
+
+









-
-
-
+
+
+
+
+
+
+
+

















+

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








 ;;	 (dboard:tabdat-logs-textbox-set! tabdat logs-tb)
 ;;	 logs-tb))

;; browse runs as a tree. Used in both "Runs" tab and
;; in the runs control panel.
;;
(define (dboard:runs-tree-browser commondat tabdat)
  (let* (
	 (txtbox (iup:textbox #:action (lambda (val a b)
					 (debug:catch-and-dump
					  (lambda ()
					    ;; for the Runs view we put the list of keyvals into tabdat target
					    ;; for the Run Controls we put then update the run-command
					    (if b (dboard:tabdat-target-set! tabdat (string-split b "/")))
					    (dashboard:update-run-command tabdat))
					  "command-testname-selector tb action"))
			      #:value (dboard:test-patt->lines
				       (dboard:tabdat-test-patts-use tabdat))
			      #:expand "HORIZONTAL"
			      ;; #:size "10x30"
			      ))
  (let* ((txtbox (iup:textbox
		  #:action (lambda (val a b)
			     (debug:catch-and-dump
			      (lambda ()
				;; for the Runs view we put the list
				;; of keyvals into tabdat target for
				;; the Run Controls we put then update
				;; the run-command
				(if b (dboard:tabdat-target-set! tabdat
								 (string-split b "/")))
				(dashboard:update-run-command tabdat))
			      "command-testname-selector tb action"))
		  #:value (dboard:test-patt->lines
			   (dboard:tabdat-test-patts-use tabdat))
		  #:expand "HORIZONTAL"
		  ;; #:size "10x30"
		  ))
	 (tb
          (iup:treebox
           #:value 0
           #:title "Runs"     ;;  was #:name -- iup 3.19 changed
			      ;;  this... "Changed: [DEPRECATED
           #:title "Runs" ;;  was #:name -- iup 3.19 changed this... "Changed: [DEPRECATED REMOVED] removed the old attribute NAMEid from IupTree to avoid conflict with the common attribute NAME. Use the TITLEid attribute."
			      ;;  REMOVED] removed the old attribute
			      ;;  NAMEid from IupTree to avoid
			      ;;  conflict with the common attribute
			      ;;  NAME. Use the TITLEid attribute."
           #:expand "YES"
           #:addexpanded "YES"
           #:size "10x"
           #:selection-cb
           (lambda (obj id state)
             (debug:catch-and-dump
              (lambda ()
                (let* ((run-path (tree:node->path obj id))
                       (run-id    (tree-path->run-id tabdat (cdr run-path))))
                  ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ?? done below when run-id is a number
                  (dboard:tabdat-target-set! tabdat (cdr run-path)) ;; (print "run-path: " run-path)
		  (iup:attribute-set! txtbox "VALUE" (string-intersperse (cdr run-path) "/"))
                  ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ??
                  ;; done below when run-id is a number
                  (dboard:tabdat-target-set! tabdat (cdr run-path)) ;; (print
								    ;; "run-path:
								    ;; "
								    ;; run-path)
		  (iup:attribute-set! txtbox "VALUE"
				      (string-intersperse (cdr run-path) "/"))
		  (dashboard:update-run-command tabdat)
                  (dboard:tabdat-layout-update-ok-set! tabdat #f)
                  (if (number? run-id)
                      (begin
                        ;; capture last two in tabdat.
                        (dboard:tabdat-prev-run-id-set!
                         tabdat
                         (dboard:tabdat-curr-run-id tabdat))
                        (dboard:tabdat-curr-run-id-set! tabdat run-id)
                        (dboard:tabdat-view-changed-set! tabdat #t))
                      (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id))))
              "treebox"))
           ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
           )))
    (dboard:tabdat-runs-tree-set! tabdat tb)
    (iup:detachbox
     (iup:vbox 
      txtbox
      tb
      ))))

;; browse runs as a tree. Used in both "Runs" tab and
;; in the runs control panel.
;;
;;  THIS IS THE NEW ONE
;;
(define (dboard:runs-tree-new-browser commondat rdat)
  (let* ((txtbox (iup:textbox
		  #:action (lambda (val a b)
			     (debug:catch-and-dump
			      (lambda ()
				;; for the Runs view we put the list
				;; of keyvals into tabdat target for
				;; the Run Controls we put then update
				;; the run-command
				(if b (dboard:rdat-targ-sql-filt-set! rdat
								 (string-split b "/")))
				#;(dashboard:update-run-command tabdat))
			      "command-testname-selector tb action"))
		  ;; #:value (dboard:test-patt->lines  ;; This seems like it was wrong, BUG in code where it was copied from?
	          ;;		   (dboard:tabdat-test-patts-use tabdat))
		  #:expand "HORIZONTAL"
		  ;; #:size "10x30"
		  ))
	 (tb
          (iup:treebox
           #:value 0
           #:title "Runs"     ;;  was #:name -- iup 3.19 changed
			      ;;  this... "Changed: [DEPRECATED
			      ;;  REMOVED] removed the old attribute
			      ;;  NAMEid from IupTree to avoid
			      ;;  conflict with the common attribute
			      ;;  NAME. Use the TITLEid attribute."
           #:expand "YES"
           #:addexpanded "YES"
           #:size "10x"
           #:selection-cb
           (lambda (obj id state)
             (debug:catch-and-dump
              (lambda ()
                (let* ((run-path (tree:node->path obj id))
                       (run-id    (new-tree-path->run-id rdat (cdr run-path))))
                  ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ??
                  ;; done below when run-id is a number
                  (dboard:rdat-targ-sql-filt-set! rdat (cdr run-path)) ;; (print
								    ;; "run-path:
								    ;; "
								    ;; run-path)
		  (iup:attribute-set! txtbox "VALUE"
				      (string-intersperse (cdr run-path) "/"))
		  #;(dashboard:update-run-command tabdat)
                  #;(dboard:tabdat-layout-update-ok-set! tabdat #f)
                  (if (number? run-id)
                      (begin
                        ;; capture last two in tabdat.
                        (dboard:rdat-push-run-id rdat run-id)
			(dboard:rdat-view-changed-set! rdat #t))
                      (debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id))))
              "treebox"))
           ;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
           )))
    (dboard:rdat-runs-tree-set! rdat tb)
    (iup:detachbox
     (iup:vbox 
      txtbox))))
      txtbox
      tb
      ))))

;;======================================================================
;; R U N   C O N T R O L S
;;======================================================================
;;
;; A gui for launching tests
;;




︙


1672
1673
1674
1675
1676
1677
1678





1679
1680
1681
1682
1683
1684
1685

1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842








+
+
+
+
+








;;
;; display and manage a single run at a time

(define (tree-path->run-id tabdat path)
  (if (not (null? path))
      (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f)
      #f))

(define (new-tree-path->run-id rdat path)
  (if (not (null? path))
      (hash-table-ref/default (dboard:rdat-path-run-ids tabdat) path #f)
      #f))

;; (define (dboard:get-tests-dat tabdat run-id last-update)
;;   (let* ((access-mode     (dboard:tabdat-access-mode tabdat))
;;          (tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run
;;                                              run-id 
;; 					     (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
;; 					     (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat))  ;; '()




︙


2426
2427
2428
2429
2430
2431
2432

















2433





































































































































2434
2435
2436

2437
2438
2439
2440
2441
2442
2443

2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751








+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+



+








				      (debug:print 6 *default-log-port* "(dboard:tabdat-start-run-offset tabdat) " (dboard:tabdat-start-run-offset tabdat) " maxruns: " maxruns ", val: " val " oldmax: " oldmax)
				      (iup:attribute-set! obj "MAX" (* maxruns 10))))
		#:expand "HORIZONTAL"
		#:max (* 10 (max (hash-table-size (dboard:tabdat-allruns-by-id tabdat)) 10))
		#:min 0
		#:step 0.01))

;; make-simple-run                   procedure (target3772 id3773 runname3774 state3775 status3776 owner3777 event_time3778)
;; rmt:simple-get-runs               procedure (runpatt1001 count1002 offset1003 target1004)
;; simple-run-event_time             procedure (x3834)
;; simple-run-event_time-set!        procedure (x3830 val3831)
;; simple-run-id                     procedure (x3794)
;; simple-run-id-set!                procedure (x3790 val3791)
;; simple-run-owner                  procedure (x3826)
;; simple-run-owner-set!             procedure (x3822 val3823)
;; simple-run-runname                procedure (x3802)
;; simple-run-runname-set!           procedure (x3798 val3799)
;; simple-run-state                  procedure (x3810)
;; simple-run-state-set!             procedure (x3806 val3807)
;; simple-run-status                 procedure (x3818)
;; simple-run-status-set!            procedure (x3814 val3815)
;; simple-run-target                 procedure (x3786)
;; simple-run-target-set!            procedure (x3782 val3783)
;; simple-run?                       procedure (x3780)


;;======================================================================
;; Extracting the data to display for runs
;;
;; This needs to be re-entrant such that it does one column per call
;; on the zeroeth call update runs data
;; on each subsequent call update one run (configurable - could do two, three ... or update until tdelta exceeded
;; on last run reset to zeroeth
;;
;;   1. select with run filters; area, target, runname, runstate, runstatus, starttime, duration
;;       - put this information into two data structures:
;;         a. hash of area/target/runname => runstruct #< ordernun, id, area, target, runname, state,
;;                                                        status, starttime, duration, non-deleted testcount>
;;            ordernum reflects order as received from sql query
;;         b. sparsevec of id => runstruct
;;   2. for each run in runshash ordered by ordernum do:
;;         retrieve data since last update for that run
;;         if there is a deleted test - retrieve full data
;;         if there are non-deleted tests register this run in the columns sparsevec
;;         if this is the zeroeth column regenerate the rows sparsevec
;;         if this column is in the visible zone update visible cells
;;
;; Other factors:
;;   1. left index handling:
;;       - add test/itempaths to left index as discovered, re-order and
;;         update row -> test/itempath mapping on each read run
;;======================================================================

;; runs is <vec header runs>
;;   get ALL runs info
;;   update rdat-targ-run-id
;;   update rdat-runs
;;
(define (dashboard:update-runs-data rdat)
  (let* ((tb               (dboard:rdat-runs-tree rdat))
	 (targ-sql-filt    (dboard:rdat-targ-sql-filt    rdat))
	 (runname-sql-filt (dboard:rdat-runname-sql-filt rdat))
	 (state-sql-filt   (dboard:rdat-run-state-sql-filt   rdat))
	 (status-sql-filt  (dboard:rdat-run-status-sql-filt  rdat))
	 ;; Use (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
	 (data             (rmt:simple-get-runs runname-sql-filt #f #f targ-sql-filt #f))
	 (numruns          (length data)))
    ;; store in the runsbynum vector
    (dboard:rdat-runsbynum-set! rdat (list->vector data))
    ;; update runs       id              => runrec
    ;; update targ-runid target/runname  => run-id
    (for-each
     (lambda (runrec)
       (let* ((run-id (simple-run-id runrec))
	      (full-targ-runname (conc (simple-run-target runrec) "/"
				       (simple-run-runname runrec))))
	 (debug:print 0 *default-log-port* "Update run  " run-id)
	 (sparse-vector-set! (dboard:rdat-runs rdat) run-id runrec)
	 (hash-table-set! (dboard:rdat-targ-runid rdat) full-targ-runname run-id)
	 ))
     data)
    numruns))

;; NOTE: runnum is NOT the run-id, it is a pointer into the runsbynum vector
;;
(define (dashboard:update-run-data runnum rdat)
  (let* ((curr-time            (current-seconds))
	 (runrec               (vector-ref (dboard:rdat-runsbynum rdat) runnum))
	 (run-id               (simple-run-id runrec))
	 (last-update          (sparse-vector-ref (dboard:rdat-last-updates rdat) run-id))
	 ;; filters
	 (testname-sql-filt    (dboard:rdat-testname-sql-filt    rdat))
	 ;; (itempath-sql-filt    (dboard:rdat-itempath-sql-filt    rdat))
	 (test-state-sql-filt  (dboard:rdat-test-state-sql-filt  rdat))  ;; not used yet
	 (test-status-sql-filt (dboard:rdat-test-status-sql-filt rdat))  ;; not used yet
	 (tests                (rmt:get-tests-for-run-state-status run-id
						      testname-sql-filt
						      last-update                ;; last-update
						      )))
    (sparse-vector-set! (dboard:rdat-last-updates rdat) run-id (- curr-time 1))
    (debug:print 0 *default-log-port* "Got " (length tests) " tests for run-id "
		 run-id " testname-sql-filt " testname-sql-filt " and last-update " last-update) 
    (length tests)))

(define (new-runs-updater commondat rdat)
  (let* ((runnum           (dboard:rdat-runnum          rdat))
	 (start-time       (current-milliseconds))
	 (tot-runs         #f))
    (if (eq? runnum 0)(dashboard:update-runs-data rdat))
    (set! tot-runs (vector-length (dboard:rdat-runsbynum rdat)))
    (let loop ((rn   runnum))
      (if (and (< (- (current-milliseconds) start-time) 250)
	       (< rn tot-runs))
	  (let* ((newrn (if (>= runnum (vector-length (dboard:rdat-runsbynum rdat)))
			    0 ;; start over
			    (+ rn 1)))) ;; (+ runnum 1)))
	    (dashboard:update-run-data rn rdat)
	    (dboard:rdat-runnum-set! rdat newrn)
	    (if (> newrn 0)
		(loop newrn)))))
    (if (>=  (dboard:rdat-runnum rdat) tot-runs)
	(dboard:rdat-runnum-set! rdat 0))
    ;; (dboard:rdat-runnum-set! rdat rn))) ;; not needed as it is set above
    ;; (dboard:rdat-last-update-set! rdat (- (current-seconds) 10))
    ;;    	 (tree:add-node tb "Runs" (string-split full-targ-runname "/"))
    '()))

(define (dboard:runs-new-matrix commondat rdat)
  (iup:matrix
   #:alignment1 "ALEFT"
   ;; #:expand "YES" ;; "HORIZONTAL"
   #:scrollbar "YES"
   #:numcol 10
   #:numlin 20
   #:numcol-visible 5 ;; (min 8)
   #:numlin-visible 1
   #:click-cb
   (lambda (obj row col status)
     (let* ((cell (conc row ":" col)))
       #f))
   ))
	 
(define (make-runs-view commondat rdat tab-num)
  ;; register an updater
  (dboard:commondat-add-updater
   commondat
   (lambda ()
     (new-runs-updater commondat rdat))
   tab-num: tab-num)

  (iup:vbox
   (iup:split
    #:orientation "VERTICAL" ;; "HORIZONTAL"
    #:value 100
    (dboard:runs-tree-new-browser commondat rdat)
    (dboard:runs-new-matrix commondat rdat)
    )))

(define (make-dashboard-buttons commondat) ;;  runs-sum-dat new-view-dat)
  (let* ((stats-dat       (dboard:tabdat-make-data))
	 (runs-dat        (dboard:tabdat-make-data))
	 (runs2-dat       (make-dboard:rdat)) ;; (dboard:tabdat-make-data))
	 (onerun-dat      (dboard:tabdat-make-data)) ;; name for run-summary structure 
	 (runcontrols-dat (dboard:tabdat-make-data))
	 (runtimes-dat    (dboard:tabdat-make-data))
	 (nruns           (dboard:tabdat-numruns runs-dat))
	 (ntests          (dboard:tabdat-num-tests runs-dat))
	 (keynames        (dboard:tabdat-dbkeys runs-dat))
	 (nkeys           (length keynames))




︙


2475
2476
2477
2478
2479
2480
2481



2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497



















2498
2499
2500
2501
2502
2503
2504

2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
















2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818








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








					res))
				    keynames)))))
    (let loop ((testnum  0)
	       (res      '()))
      (cond
       ((>= testnum ntests)
	;; now lftlst will be an hbox with the test keys and the test name labels
	(set! lftlst
	      (append lftlst
		      (list (iup:hbox
	(set! lftlst (append lftlst (list (iup:hbox  #:expand "HORIZONTAL"
						     (iup:valuator #:valuechanged_cb (lambda (obj)
										       (let ((val (string->number (iup:attribute obj "VALUE")))
											     (oldmax  (string->number (iup:attribute obj "MAX")))
											     (newmax  (* 10 (length (dboard:tabdat-all-test-names runs-dat)))))
											 (dboard:commondat-please-update-set! commondat #t)
											 (dboard:tabdat-start-test-offset-set! runs-dat (inexact->exact (round (/ val 10))))
											 (debug:print 6 *default-log-port* "(dboard:tabdat-start-test-offset runs-dat) " (dboard:tabdat-start-test-offset runs-dat) " val: " val " newmax: " newmax " oldmax: " oldmax)
											 (if (< val 10)
											     (iup:attribute-set! obj "MAX" newmax))
											 ))
								   #:expand "VERTICAL" 
								   #:orientation "VERTICAL"
								   #:min 0
								   #:step 0.01)
						     (apply iup:vbox (reverse res)))))))
			     #:expand "HORIZONTAL"
			     (iup:valuator
			      #:valuechanged_cb (lambda (obj)
						  (let ((val (string->number (iup:attribute obj "VALUE")))
							(oldmax  (string->number (iup:attribute obj "MAX")))
							(newmax  (* 10 (length (dboard:tabdat-all-test-names runs-dat)))))
						    (dboard:commondat-please-update-set! commondat #t)
						    (dboard:tabdat-start-test-offset-set! runs-dat (inexact->exact (round (/ val 10))))
						    (debug:print 6 *default-log-port* "(dboard:tabdat-start-test-offset runs-dat) "
								 (dboard:tabdat-start-test-offset runs-dat) " val: " val
								 " newmax: " newmax " oldmax: " oldmax)
						    (if (< val 10)
							(iup:attribute-set! obj "MAX" newmax))
						    ))
			      #:expand "VERTICAL" 
			      #:orientation "VERTICAL"
			      #:min 0
			      #:step 0.01)
			     (apply iup:vbox (reverse res)))))))
       (else
	(let ((labl  (iup:button "" ;; the testname labels
				 #:flat "YES" 
				 #:alignment "ALEFT"
					; #:image img1
					; #:impress img2
				 #:size  (conc cell-width btn-height)




︙


2604
2605
2606
2607
2608
2609
2610
2611

2612
2613
2614
2615
2616
2617
2618

2918
2919
2920
2921
2922
2923
2924

2925
2926
2927
2928
2929
2930
2931
2932








-
+








			    (apply iup:hbox (reverse hdrlst))
			    (apply iup:hbox (reverse bdylst))
			    (dashboard:runs-horizontal-slider runs-dat))))
			 controls
			 ))
	     (views-cfgdat (common:load-views-config))
	     (additional-tabnames '())
	     (tab-start-num       5)   ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW
	     (tab-start-num       6)   ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW
	     ;; (data (dboard:tabdat-init (make-d:data)))
	     (additional-views 	;; process views-dat
	      (let ((tab-num tab-start-num)
		    (result  '()))
		(for-each
		 (lambda (view-name)
		   (debug:print 0 *default-log-port* "Adding view " view-name)




︙


2646
2647
2648
2649
2650
2651
2652

2653

2654
2655
2656


2657
2658
2659
2660
2661
2662
2663
2664




2665
2666
2667
2668
2669
2670
2671

2960
2961
2962
2963
2964
2965
2966
2967

2968
2969


2970
2971
2972
2973
2974
2975
2976



2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987








+
-
+

-
-
+
+





-
-
-
+
+
+
+








							(tabdat  (dboard:common-get-tabdat commondat tab-num: tab-num)))
               
						   (dboard:commondat-please-update-set! commondat #t)
						   (dboard:tabdat-layout-update-ok-set! tabdat #t)))
					       "tabchangepos"))
			  (dashboard:summary commondat stats-dat tab-num: 0)
			  runs-view
			  (make-runs-view commondat runs2-dat 2)
			  (dashboard:runs-summary commondat onerun-dat tab-num: 2)
			  (dashboard:runs-summary commondat onerun-dat tab-num: 3)
			  ;; (dashboard:new-view db data new-view-dat tab-num: 3)
			  (dashboard:run-controls commondat runcontrols-dat tab-num: 3)
			  (dashboard:run-times commondat runtimes-dat tab-num: 4)
			  (dashboard:run-controls commondat runcontrols-dat tab-num: 4)
			  (dashboard:run-times commondat runtimes-dat tab-num: 5)
			  ;; (dashboard:runs-summary commondat onerun-dat tab-num: 4)
			  additional-views)))
	;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
	(iup:attribute-set! tabs "TABTITLE0" "Summary")
	(iup:attribute-set! tabs "TABTITLE1" "Runs")
	(iup:attribute-set! tabs "TABTITLE2" "Run Summary")
	(iup:attribute-set! tabs "TABTITLE3" "Run Control")
	(iup:attribute-set! tabs "TABTITLE4" "Run Times")
	(iup:attribute-set! tabs "TABTITLE2" "Runs2")
	(iup:attribute-set! tabs "TABTITLE3" "Run Summary")
	(iup:attribute-set! tabs "TABTITLE4" "Run Control")
	(iup:attribute-set! tabs "TABTITLE5" "Run Times")
	;; (iup:attribute-set! tabs "TABTITLE3" "New View")
	;; (iup:attribute-set! tabs "TABTITLE4" "Run Control")

	;; set the tab names for user added tabs
	(for-each
	 (lambda (tab-info)
	   (iup:attribute-set! tabs (conc "TABTITLE" (car tab-info)) (cdr tab-info)))




︙


3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439

3732
3733
3734
3735
3736
3737
3738




3739



3740

3741
3742
3743
3744
3745
3746
3747








-
-
-
-

-
-
-

-








       fres))))

(define (dashboard:runs-tab-updater commondat tab-num)
  (debug:catch-and-dump 
   (lambda ()
     (let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))
	    (dbkeys (dboard:tabdat-dbkeys tabdat)))
       ;;(print "RA => calling runs-tab-updater with commondat " commondat " tab-num " tab-num)
       ;;(tabdat-values tabdat) ;;RA added 
       ;; (pp (dboard:tabdat->alist tabdat))
       ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-rundat)      
       (dashboard:do-update-rundat tabdat)
       ;;(debug:print-info 13 *default-log-port* "dashboard:runs-tab-updater")
       ;;(inspect tabdat)

       (let ((uidat (dboard:commondat-uidat commondat)))
	 ;;(print "RA => Calling update-buttons with tabdat : " tabdat " uidat " uidat)
	 (update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat)))
       ))
   "dashboard:runs-tab-updater"))

;;======================================================================
;; The heavy lifting starts here
;;======================================================================




︙


3467
3468
3469
3470
3471
3472
3473





3474
3475
3476
3477
3478
3479
3480

3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793








+
+
+
+
+








	(dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat))
	(dboard:commondat-curr-tab-num-set! commondat 0)
	(dboard:commondat-add-updater 
	 commondat 
	 (lambda ()
	   (dashboard:runs-tab-updater commondat 1))
	 tab-num: 1)
	(dboard:commondat-add-updater 
	 commondat 
	 (lambda ()
	   (dashboard:runs-tab-updater commondat 1))
	 tab-num: 2)
	(iup:callback-set! *tim*
			   "ACTION_CB"
			   (lambda (time-obj)
			     (let ((update-is-running #f))
			     (mutex-lock! (dboard:commondat-update-mutex commondat))
			     (set! update-is-running (dboard:commondat-updating commondat))
			     (if (not update-is-running)




︙







Modified db.scm
from [4dafe820e6]
to [4b75655ccf].




︙


2070
2071
2072
2073
2074
2075
2076




2077
2078
2079
2080
2081
2082
2083

2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087








+
+
+
+








		       (lambda (key)
			 (set! res (cons key res)))
		       db
		       "SELECT fieldname FROM keys ORDER BY id DESC;")))
	(set! *db-keys* res)
	res)))

;; extract index number given a header/data structure
(define (db:get-index-by-header header field)
  (list-index (lambda (x)(equal? x field)) header))

;; look up values in a header/data structure
(define (db:get-value-by-header row header field)
  (if (or (null? header) (not row))
      #f
      (let loop ((hed (car header))
                 (tal (cdr header))
                 (n   0))




︙


2256
2257
2258
2259
2260
2261
2262
2263

2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274





2275
2276
2277
2278
2279
2280


2281
2282
2283
2284
2285
2286
2287

2260
2261
2262
2263
2264
2265
2266

2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277

2278
2279
2280
2281
2282
2283
2284
2285
2286
2287

2288
2289
2290
2291
2292
2293
2294
2295
2296








-
+










-
+
+
+
+
+





-
+
+








(define-record simple-run target id runname state status owner event_time)
(define-record-printer (simple-run x out)
  (fprintf out "#,(simple-run ~S ~S ~S ~S)"
	   (simple-run-target x) (simple-run-id x) (simple-run-runname x) (time->string (seconds->local-time (simple-run-event_time x) ))))

;; simple get-runs
;;
(define (db:simple-get-runs dbstruct runpatt count offset target)
(define (db:simple-get-runs dbstruct runpatt count offset target last-update)
    (let* ((res       '())
	   (keys       (db:get-keys dbstruct))
	   (runpattstr (db:patt->like "runname" runpatt))
	   (remfields  (list "id" "runname" "state" "status" "owner" "event_time"))
	   (targstr    (string-intersperse keys "||'/'||"))
	   (keystr     (conc targstr " AS target,"
			     (string-intersperse remfields ",")))
	   (qrystr     (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? "
			     ;; Generate: " AND x LIKE 'keypatt' ..."
			     " AND target LIKE '" target "'"
			     " AND state != 'deleted' ORDER BY event_time DESC "
			     " AND state != 'deleted' "
			     (if (number? last-update)
				 (conc " AND last_update >= " last-update)
				 "")
			     " ORDER BY event_time DESC "
			     (if (number? count)
				 (conc " LIMIT " count)
				 "")
			     (if (number? offset)
				 (conc " OFFSET " offset)
				 ""))))
				 "")))
	   )
    (debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " target: " target " offset: " offset " limit: " count)
    (db:with-db dbstruct #f #f
		(lambda (db)		
		  (sqlite3:for-each-row
		   (lambda (target id runname state status owner event_time)
		     (set! res (cons (make-simple-run target id runname state status owner event_time) res)))
		   db




︙


2870
2871
2872
2873
2874
2875
2876
2877

2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892




















2893
2894
2895
2896
2897
2898
2899

2879
2880
2881
2882
2883
2884
2885

2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928








-
+















+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








	  (vector-ref inrec 2) ;; testname
	  (vector-ref inrec 4) ;; state
	  (vector-ref inrec 5) ;; status
	  -1 "" -1 -1 "" "-" 
	  (vector-ref inrec 3) ;; item-path
	  -1 "-" "-"))

(define (db:get-tests-for-run-state-status dbstruct run-id testpatt)
#;(define (db:get-tests-for-run-state-status dbstruct run-id testpatt)
  (let* ((res            '())
	 (tests-match-qry (tests:match->sqlqry testpatt))
	 (qry             (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " 
				(if tests-match-qry (conc " AND (" tests-match-qry ") ") ""))))
    (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry)
    (db:with-db dbstruct run-id #f
		(lambda (db)
		  (sqlite3:for-each-row
		   (lambda (id testname item-path state status)
		     ;;                      id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
		     (set! res (cons (vector id run-id testname state status -1         ""     -1      -1       ""    "-"  item-path -1           "-"         "-") res)))
		   db 
		   qry
		   run-id)))
    res))

(define (db:get-tests-for-run-state-status dbstruct run-id testpatt #!optional (last-update 0))
  (let* ((res            '())
	 (tests-match-qry (tests:match->sqlqry testpatt))
	 (qry             (conc "SELECT id,testname,item_path,state,status,event_time,run_duration FROM tests WHERE run_id=? " 
				" AND last_update > ? "
				(if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
				)))
    (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry)
    (db:with-db dbstruct run-id #f
		(lambda (db)
		  (sqlite3:fold-row
		   (lambda (res id testname item-path state status event-time run-duration)
		     ;;            id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
		     (cons (vector id run-id testname state status event-time  ""     -1      -1       ""    "-"  item-path run-duration  "-"         "-") res))
		   '()
		   db 
		   qry
		   run-id
		   (or last-update 0))))))

(define (db:get-testinfo-state-status dbstruct run-id test-id)
  (let ((res            #f))
    (db:with-db dbstruct run-id #f
		(lambda (db)
		  (sqlite3:for-each-row
		   (lambda (run-id testname item-path state status)




︙







Added dbmod.scm version [2029a02dc3].











































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;;======================================================================
;; Copyright 2017, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================

(declare (unit dbmod))

(module dbmod
	*
	
(import scheme chicken data-structures extras)
(import (prefix sqlite3 sqlite3:) posix typed-records srfi-18)

(define (just-testing)
  (print "JUST TESTING"))

;; (define (debug:print . params) #f)
;; (define (debug:print-info . params) #f)
;; 
;; (define (set-functions dbgp dbgpinfo)
;;   (set! debug:print dbgp)
;;   (set! debug:print-info dbgpinfo))

)








Modified diff-report.scm
from [722e4fdcd5]
to [1eae9c3686].




︙


19
20
21
22
23
24
25
26

27
28
29
30
31
32
33

19
20
21
22
23
24
25

26
27
28
29
30
31
32
33








-
+








(declare (unit diff-report))
(declare (uses common))
(declare (uses rmt))
         
(include "common_records.scm")
(use matchable)
(use fmt)
(use ducttape-lib)
(import ducttape-lib)
(define css "")

(define (diff:tests-mindat->hash tests-mindat)
  (let* ((res (make-hash-table)))
    (for-each
     (lambda (item)
       (let* ((test-name+item-path (cons (list-ref item 0) (list-ref item 1)))




︙







Added ducttape-lib.scm version [ee2ef474af].



























1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;;======================================================================
;; Copyright 2019, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================

(declare (unit ducttape-lib))

(include "ducttape/ducttape-lib.scm")








Added ducttape/Makefile version [9efb623beb].






































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

help:
	@echo ""
	@echo "make targets:"
	@echo "============="
	@echo "install      - build and install general_lib egg as icfadm"
	@echo "test         - run unit tests on ducttape-lib.scm (tests code, not egg)"
	@echo "eggs-info     - show chicken-install commands to get eggs upon which ducttape-lib depends"
	@echo "test_example - compile an example scm against installed general_lib egg"
	@echo "clean        - remove binaries and other build artifacts"
	@echo ""

clean:
	rm -f *.so *.import.scm test_ducttape test_example foo *.c *.o

install:
	chicken-install

test:
	echo '(handle-exceptions exn (begin (print-call-chain) (exit 1)) (load "ducttape-lib.scm") (inote "hello")) (exit 0)'  | csi
	chicken-install -no-install
	csc test_ducttape.scm

	./test_ducttape
	rm -f foo

test_example:
	@csc test_example.scm
	@./test_example
	@rm test_example

eggs-info:
	@echo chicken-install ansi-escape-sequences
	@echo chicken-install slice
	@echo chicken-install rfc3339








Added ducttape/README version [bc9be285fc].












1
2
3
4
5
6
7
8

+
+
+
+
+
+
+
+

This directory holds the "ducttape" chicken scheme egg used by megatest.

Run "make test" to ensure this egg works on your system.

Run "make install" as your admin user with chicken on your $PATH to install this egg.











Added ducttape/ducttape-lib.meta version [a22283c9d8].

















1
2
3
4
5
6
7
8
9
10
11
12
13

+
+
+
+
+
+
+
+
+
+
+
+
+

;;; ducttape-lib.meta -*- Hen -*-

((egg "ducttape-lib.egg")
 (synopsis "Miscellaneous tool and standard print routines.")
 (category env)
 (author "Brandon Barclay")
 (doc-from-wiki)
 (license "GPL-2")
 ;; srfi-69, posix, srfi-18
 (depends regex)
 (test-depends test)
 ; suspicious - (files "ducttape-lib")
 )








Added ducttape/ducttape-lib.scm version [59b0a2f94a].





















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
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
227
228
229
230
231
232
233
234
235
236
237
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
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
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
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
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
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

(module ducttape-lib
    (
     runs-ok
     ducttape-debug-level
     ducttape-debug-regex-filter
     ducttape-silent-mode
     ducttape-quiet-mode
     ducttape-log-file
     ducttape-color-mode
     iputs-preamble
     script-name
     idbg
     ierr
     iwarn
     inote
     iputs
     re-match?
                                        ;     launch-repl
     keyword-skim
     skim-cmdline-opts-noarg-by-regex
     skim-cmdline-opts-withargs-by-regex
     get-cli-arg
     get-cli-switch
     concat-lists
     ducttape-process-command-line
     ducttape-append-logfile
     ducttape-activate-logfile
     isys
     do-or-die
     counter-maker
     dir-is-writable?
     mktemp
     get-tmpdir
     sendmail
     find-exe

     zeropad
     string-leftpad
     string-rightpad
     seconds->isodate
     seconds->wwdate
     seconds->wwdate-values
     isodate->seconds
     isodate->wwdate
     wwdate->seconds
     wwdate->isodate
     current-wwdate
     current-isodate
     *this-exe-dir*
     *this-exe-name*
     *this-exe-fullpath*
     )

  (import scheme chicken extras ports data-structures )
  (use posix regex ansi-escape-sequences test srfi-1 irregex slice srfi-13 rfc3339)
  ;;scsh-process ;; dropping scsh-process, it was clobbering posix's process and process*
  (use directory-utils uuid-lib filepath srfi-19 ) ; linenoise

    ;; plugs a hole in posix-extras in latter chicken versions
  (use posix-extras pathname-expand files)
  (define ##sys#expand-home-path pathname-expand)
  (define (realpath x) (resolve-pathname  (pathname-expand (or x "/dev/null")) ))

  ;; (include "mimetypes.scm") ; provides ext->mimetype
  ;; (include "workweekdate.scm")

  ;; gathered from macosx:
;;   cat /etc/apache2/mime.types | grep -v '^#' | perl -ne 'print "(\"$2\" . \"$1\")\n" if /(\S+)\s+(\S+)/' > mimetypes.scm
;; + manual manipulation

(define ducttape_ext2mimetype '(("ez" . "application/andrew-inset")
("aw" . "application/applixware")
("atom" . "application/atom+xml")
("atomcat" . "application/atomcat+xml")
("atomsvc" . "application/atomsvc+xml")
("ccxml" . "application/ccxml+xml")
("cdmia" . "application/cdmi-capability")
("cdmic" . "application/cdmi-container")
("cdmid" . "application/cdmi-domain")
("cdmio" . "application/cdmi-object")
("cdmiq" . "application/cdmi-queue")
("cu" . "application/cu-seeme")
("davmount" . "application/davmount+xml")
("dbk" . "application/docbook+xml")
("dssc" . "application/dssc+der")
("xdssc" . "application/dssc+xml")
("ecma" . "application/ecmascript")
("emma" . "application/emma+xml")
("epub" . "application/epub+zip")
("exi" . "application/exi")
("pfr" . "application/font-tdpfr")
("gml" . "application/gml+xml")
("gpx" . "application/gpx+xml")
("gxf" . "application/gxf")
("stk" . "application/hyperstudio")
("ink" . "application/inkml+xml")
("ipfix" . "application/ipfix")
("jar" . "application/java-archive")
("ser" . "application/java-serialized-object")
("class" . "application/java-vm")
("js" . "application/javascript")
("json" . "application/json")
("jsonml" . "application/jsonml+json")
("lostxml" . "application/lost+xml")
("hqx" . "application/mac-binhex40")
("cpt" . "application/mac-compactpro")
("mads" . "application/mads+xml")
("mrc" . "application/marc")
("mrcx" . "application/marcxml+xml")
("ma" . "application/mathematica")
("mathml" . "application/mathml+xml")
("mbox" . "application/mbox")
("mscml" . "application/mediaservercontrol+xml")
("metalink" . "application/metalink+xml")
("meta4" . "application/metalink4+xml")
("mets" . "application/mets+xml")
("mods" . "application/mods+xml")
("m21" . "application/mp21")
("mp4s" . "application/mp4")
("doc" . "application/msword")
("mxf" . "application/mxf")
("bin" . "application/octet-stream")
("oda" . "application/oda")
("opf" . "application/oebps-package+xml")
("ogx" . "application/ogg")
("omdoc" . "application/omdoc+xml")
("onetoc" . "application/onenote")
("oxps" . "application/oxps")
("xer" . "application/patch-ops-error+xml")
("pdf" . "application/pdf")
("pgp" . "application/pgp-encrypted")
("asc" . "application/pgp-signature")
("prf" . "application/pics-rules")
("p10" . "application/pkcs10")
("p7m" . "application/pkcs7-mime")
("p7s" . "application/pkcs7-signature")
("p8" . "application/pkcs8")
("ac" . "application/pkix-attr-cert")
("cer" . "application/pkix-cert")
("crl" . "application/pkix-crl")
("pkipath" . "application/pkix-pkipath")
("pki" . "application/pkixcmp")
("pls" . "application/pls+xml")
("ai" . "application/postscript")
("cww" . "application/prs.cww")
("pskcxml" . "application/pskc+xml")
("rdf" . "application/rdf+xml")
("rif" . "application/reginfo+xml")
("rnc" . "application/relax-ng-compact-syntax")
("rl" . "application/resource-lists+xml")
("rld" . "application/resource-lists-diff+xml")
("rs" . "application/rls-services+xml")
("gbr" . "application/rpki-ghostbusters")
("mft" . "application/rpki-manifest")
("roa" . "application/rpki-roa")
("rsd" . "application/rsd+xml")
("rss" . "application/rss+xml")
("rtf" . "application/rtf")
("sbml" . "application/sbml+xml")
("scq" . "application/scvp-cv-request")
("scs" . "application/scvp-cv-response")
("spq" . "application/scvp-vp-request")
("spp" . "application/scvp-vp-response")
("sdp" . "application/sdp")
("setpay" . "application/set-payment-initiation")
("setreg" . "application/set-registration-initiation")
("shf" . "application/shf+xml")
("smi" . "application/smil+xml")
("rq" . "application/sparql-query")
("srx" . "application/sparql-results+xml")
("gram" . "application/srgs")
("grxml" . "application/srgs+xml")
("sru" . "application/sru+xml")
("ssdl" . "application/ssdl+xml")
("ssml" . "application/ssml+xml")
("tei" . "application/tei+xml")
("tfi" . "application/thraud+xml")
("tsd" . "application/timestamped-data")
("plb" . "application/vnd.3gpp.pic-bw-large")
("psb" . "application/vnd.3gpp.pic-bw-small")
("pvb" . "application/vnd.3gpp.pic-bw-var")
("tcap" . "application/vnd.3gpp2.tcap")
("pwn" . "application/vnd.3m.post-it-notes")
("aso" . "application/vnd.accpac.simply.aso")
("imp" . "application/vnd.accpac.simply.imp")
("acu" . "application/vnd.acucobol")
("atc" . "application/vnd.acucorp")
("air" . "application/vnd.adobe.air-application-installer-package+zip")
("fcdt" . "application/vnd.adobe.formscentral.fcdt")
("fxp" . "application/vnd.adobe.fxp")
("xdp" . "application/vnd.adobe.xdp+xml")
("xfdf" . "application/vnd.adobe.xfdf")
("ahead" . "application/vnd.ahead.space")
("azf" . "application/vnd.airzip.filesecure.azf")
("azs" . "application/vnd.airzip.filesecure.azs")
("azw" . "application/vnd.amazon.ebook")
("acc" . "application/vnd.americandynamics.acc")
("ami" . "application/vnd.amiga.ami")
("apk" . "application/vnd.android.package-archive")
("cii" . "application/vnd.anser-web-certificate-issue-initiation")
("fti" . "application/vnd.anser-web-funds-transfer-initiation")
("atx" . "application/vnd.antix.game-component")
("mpkg" . "application/vnd.apple.installer+xml")
("m3u8" . "application/vnd.apple.mpegurl")
("swi" . "application/vnd.aristanetworks.swi")
("iota" . "application/vnd.astraea-software.iota")
("aep" . "application/vnd.audiograph")
("mpm" . "application/vnd.blueice.multipass")
("bmi" . "application/vnd.bmi")
("rep" . "application/vnd.businessobjects")
("cdxml" . "application/vnd.chemdraw+xml")
("mmd" . "application/vnd.chipnuts.karaoke-mmd")
("cdy" . "application/vnd.cinderella")
("cla" . "application/vnd.claymore")
("rp9" . "application/vnd.cloanto.rp9")
("c4g" . "application/vnd.clonk.c4group")
("c11amc" . "application/vnd.cluetrust.cartomobile-config")
("c11amz" . "application/vnd.cluetrust.cartomobile-config-pkg")
("csp" . "application/vnd.commonspace")
("cdbcmsg" . "application/vnd.contact.cmsg")
("cmc" . "application/vnd.cosmocaller")
("clkx" . "application/vnd.crick.clicker")
("clkk" . "application/vnd.crick.clicker.keyboard")
("clkp" . "application/vnd.crick.clicker.palette")
("clkt" . "application/vnd.crick.clicker.template")
("clkw" . "application/vnd.crick.clicker.wordbank")
("wbs" . "application/vnd.criticaltools.wbs+xml")
("pml" . "application/vnd.ctc-posml")
("ppd" . "application/vnd.cups-ppd")
("car" . "application/vnd.curl.car")
("pcurl" . "application/vnd.curl.pcurl")
("dart" . "application/vnd.dart")
("rdz" . "application/vnd.data-vision.rdz")
("uvf" . "application/vnd.dece.data")
("uvt" . "application/vnd.dece.ttml+xml")
("uvx" . "application/vnd.dece.unspecified")
("uvz" . "application/vnd.dece.zip")
("fe_launch" . "application/vnd.denovo.fcselayout-link")
("dna" . "application/vnd.dna")
("mlp" . "application/vnd.dolby.mlp")
("dpg" . "application/vnd.dpgraph")
("dfac" . "application/vnd.dreamfactory")
("kpxx" . "application/vnd.ds-keypoint")
("ait" . "application/vnd.dvb.ait")
("svc" . "application/vnd.dvb.service")
("geo" . "application/vnd.dynageo")
("mag" . "application/vnd.ecowin.chart")
("nml" . "application/vnd.enliven")
("esf" . "application/vnd.epson.esf")
("msf" . "application/vnd.epson.msf")
("qam" . "application/vnd.epson.quickanime")
("slt" . "application/vnd.epson.salt")
("ssf" . "application/vnd.epson.ssf")
("es3" . "application/vnd.eszigno3+xml")
("ez2" . "application/vnd.ezpix-album")
("ez3" . "application/vnd.ezpix-package")
("fdf" . "application/vnd.fdf")
("mseed" . "application/vnd.fdsn.mseed")
("seed" . "application/vnd.fdsn.seed")
("gph" . "application/vnd.flographit")
("ftc" . "application/vnd.fluxtime.clip")
("fm" . "application/vnd.framemaker")
("fnc" . "application/vnd.frogans.fnc")
("ltf" . "application/vnd.frogans.ltf")
("fsc" . "application/vnd.fsc.weblaunch")
("oas" . "application/vnd.fujitsu.oasys")
("oa2" . "application/vnd.fujitsu.oasys2")
("oa3" . "application/vnd.fujitsu.oasys3")
("fg5" . "application/vnd.fujitsu.oasysgp")
("bh2" . "application/vnd.fujitsu.oasysprs")
("ddd" . "application/vnd.fujixerox.ddd")
("xdw" . "application/vnd.fujixerox.docuworks")
("xbd" . "application/vnd.fujixerox.docuworks.binder")
("fzs" . "application/vnd.fuzzysheet")
("txd" . "application/vnd.genomatix.tuxedo")
("ggb" . "application/vnd.geogebra.file")
("ggt" . "application/vnd.geogebra.tool")
("gex" . "application/vnd.geometry-explorer")
("gxt" . "application/vnd.geonext")
("g2w" . "application/vnd.geoplan")
("g3w" . "application/vnd.geospace")
("gmx" . "application/vnd.gmx")
("kml" . "application/vnd.google-earth.kml+xml")
("kmz" . "application/vnd.google-earth.kmz")
("gqf" . "application/vnd.grafeq")
("gac" . "application/vnd.groove-account")
("ghf" . "application/vnd.groove-help")
("gim" . "application/vnd.groove-identity-message")
("grv" . "application/vnd.groove-injector")
("gtm" . "application/vnd.groove-tool-message")
("tpl" . "application/vnd.groove-tool-template")
("vcg" . "application/vnd.groove-vcard")
("hal" . "application/vnd.hal+xml")
("zmm" . "application/vnd.handheld-entertainment+xml")
("hbci" . "application/vnd.hbci")
("les" . "application/vnd.hhe.lesson-player")
("hpgl" . "application/vnd.hp-hpgl")
("hpid" . "application/vnd.hp-hpid")
("hps" . "application/vnd.hp-hps")
("jlt" . "application/vnd.hp-jlyt")
("pcl" . "application/vnd.hp-pcl")
("pclxl" . "application/vnd.hp-pclxl")
("sfd-hdstx" . "application/vnd.hydrostatix.sof-data")
("mpy" . "application/vnd.ibm.minipay")
("afp" . "application/vnd.ibm.modcap")
("irm" . "application/vnd.ibm.rights-management")
("sc" . "application/vnd.ibm.secure-container")
("icc" . "application/vnd.iccprofile")
("igl" . "application/vnd.igloader")
("ivp" . "application/vnd.immervision-ivp")
("ivu" . "application/vnd.immervision-ivu")
("igm" . "application/vnd.insors.igm")
("xpw" . "application/vnd.intercon.formnet")
("i2g" . "application/vnd.intergeo")
("qbo" . "application/vnd.intu.qbo")
("qfx" . "application/vnd.intu.qfx")
("rcprofile" . "application/vnd.ipunplugged.rcprofile")
("irp" . "application/vnd.irepository.package+xml")
("xpr" . "application/vnd.is-xpr")
("fcs" . "application/vnd.isac.fcs")
("jam" . "application/vnd.jam")
("rms" . "application/vnd.jcp.javame.midlet-rms")
("jisp" . "application/vnd.jisp")
("joda" . "application/vnd.joost.joda-archive")
("ktz" . "application/vnd.kahootz")
("karbon" . "application/vnd.kde.karbon")
("chrt" . "application/vnd.kde.kchart")
("kfo" . "application/vnd.kde.kformula")
("flw" . "application/vnd.kde.kivio")
("kon" . "application/vnd.kde.kontour")
("kpr" . "application/vnd.kde.kpresenter")
("ksp" . "application/vnd.kde.kspread")
("kwd" . "application/vnd.kde.kword")
("htke" . "application/vnd.kenameaapp")
("kia" . "application/vnd.kidspiration")
("kne" . "application/vnd.kinar")
("skp" . "application/vnd.koan")
("sse" . "application/vnd.kodak-descriptor")
("lasxml" . "application/vnd.las.las+xml")
("lbd" . "application/vnd.llamagraphics.life-balance.desktop")
("lbe" . "application/vnd.llamagraphics.life-balance.exchange+xml")
("123" . "application/vnd.lotus-1-2-3")
("apr" . "application/vnd.lotus-approach")
("pre" . "application/vnd.lotus-freelance")
("nsf" . "application/vnd.lotus-notes")
("org" . "application/vnd.lotus-organizer")
("scm" . "application/vnd.lotus-screencam")
("lwp" . "application/vnd.lotus-wordpro")
("portpkg" . "application/vnd.macports.portpkg")
("mcd" . "application/vnd.mcd")
("mc1" . "application/vnd.medcalcdata")
("cdkey" . "application/vnd.mediastation.cdkey")
("mwf" . "application/vnd.mfer")
("mfm" . "application/vnd.mfmp")
("flo" . "application/vnd.micrografx.flo")
("igx" . "application/vnd.micrografx.igx")
("mif" . "application/vnd.mif")
("daf" . "application/vnd.mobius.daf")
("dis" . "application/vnd.mobius.dis")
("mbk" . "application/vnd.mobius.mbk")
("mqy" . "application/vnd.mobius.mqy")
("msl" . "application/vnd.mobius.msl")
("plc" . "application/vnd.mobius.plc")
("txf" . "application/vnd.mobius.txf")
("mpn" . "application/vnd.mophun.application")
("mpc" . "application/vnd.mophun.certificate")
("xul" . "application/vnd.mozilla.xul+xml")
("cil" . "application/vnd.ms-artgalry")
("cab" . "application/vnd.ms-cab-compressed")
("xls" . "application/vnd.ms-excel")
("xlam" . "application/vnd.ms-excel.addin.macroenabled.12")
("xlsb" . "application/vnd.ms-excel.sheet.binary.macroenabled.12")
("xlsm" . "application/vnd.ms-excel.sheet.macroenabled.12")
("xltm" . "application/vnd.ms-excel.template.macroenabled.12")
("eot" . "application/vnd.ms-fontobject")
("chm" . "application/vnd.ms-htmlhelp")
("ims" . "application/vnd.ms-ims")
("lrm" . "application/vnd.ms-lrm")
("thmx" . "application/vnd.ms-officetheme")
("cat" . "application/vnd.ms-pki.seccat")
("stl" . "application/vnd.ms-pki.stl")
("ppt" . "application/vnd.ms-powerpoint")
("ppam" . "application/vnd.ms-powerpoint.addin.macroenabled.12")
("pptm" . "application/vnd.ms-powerpoint.presentation.macroenabled.12")
("sldm" . "application/vnd.ms-powerpoint.slide.macroenabled.12")
("ppsm" . "application/vnd.ms-powerpoint.slideshow.macroenabled.12")
("potm" . "application/vnd.ms-powerpoint.template.macroenabled.12")
("mpp" . "application/vnd.ms-project")
("docm" . "application/vnd.ms-word.document.macroenabled.12")
("dotm" . "application/vnd.ms-word.template.macroenabled.12")
("wps" . "application/vnd.ms-works")
("wpl" . "application/vnd.ms-wpl")
("xps" . "application/vnd.ms-xpsdocument")
("mseq" . "application/vnd.mseq")
("mus" . "application/vnd.musician")
("msty" . "application/vnd.muvee.style")
("taglet" . "application/vnd.mynfc")
("nlu" . "application/vnd.neurolanguage.nlu")
("ntf" . "application/vnd.nitf")
("nnd" . "application/vnd.noblenet-directory")
("nns" . "application/vnd.noblenet-sealer")
("nnw" . "application/vnd.noblenet-web")
("ngdat" . "application/vnd.nokia.n-gage.data")
("n-gage" . "application/vnd.nokia.n-gage.symbian.install")
("rpst" . "application/vnd.nokia.radio-preset")
("rpss" . "application/vnd.nokia.radio-presets")
("edm" . "application/vnd.novadigm.edm")
("edx" . "application/vnd.novadigm.edx")
("ext" . "application/vnd.novadigm.ext")
("odc" . "application/vnd.oasis.opendocument.chart")
("otc" . "application/vnd.oasis.opendocument.chart-template")
("odb" . "application/vnd.oasis.opendocument.database")
("odf" . "application/vnd.oasis.opendocument.formula")
("odft" . "application/vnd.oasis.opendocument.formula-template")
("odg" . "application/vnd.oasis.opendocument.graphics")
("otg" . "application/vnd.oasis.opendocument.graphics-template")
("odi" . "application/vnd.oasis.opendocument.image")
("oti" . "application/vnd.oasis.opendocument.image-template")
("odp" . "application/vnd.oasis.opendocument.presentation")
("otp" . "application/vnd.oasis.opendocument.presentation-template")
("ods" . "application/vnd.oasis.opendocument.spreadsheet")
("ots" . "application/vnd.oasis.opendocument.spreadsheet-template")
("odt" . "application/vnd.oasis.opendocument.text")
("odm" . "application/vnd.oasis.opendocument.text-master")
("ott" . "application/vnd.oasis.opendocument.text-template")
("oth" . "application/vnd.oasis.opendocument.text-web")
("xo" . "application/vnd.olpc-sugar")
("dd2" . "application/vnd.oma.dd2+xml")
("oxt" . "application/vnd.openofficeorg.extension")
("pptx" . "application/vnd.openxmlformats-officedocument.presentationml.presentation")
("sldx" . "application/vnd.openxmlformats-officedocument.presentationml.slide")
("ppsx" . "application/vnd.openxmlformats-officedocument.presentationml.slideshow")
("potx" . "application/vnd.openxmlformats-officedocument.presentationml.template")
("xlsx" . "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet")
("xltx" . "application/vnd.openxmlformats-officedocument.spreadsheetml.template")
("docx" . "application/vnd.openxmlformats-officedocument.wordprocessingml.document")
("dotx" . "application/vnd.openxmlformats-officedocument.wordprocessingml.template")
("mgp" . "application/vnd.osgeo.mapguide.package")
("dp" . "application/vnd.osgi.dp")
("esa" . "application/vnd.osgi.subsystem")
("pdb" . "application/vnd.palm")
("paw" . "application/vnd.pawaafile")
("str" . "application/vnd.pg.format")
("ei6" . "application/vnd.pg.osasli")
("efif" . "application/vnd.picsel")
("wg" . "application/vnd.pmi.widget")
("plf" . "application/vnd.pocketlearn")
("pbd" . "application/vnd.powerbuilder6")
("box" . "application/vnd.previewsystems.box")
("mgz" . "application/vnd.proteus.magazine")
("qps" . "application/vnd.publishare-delta-tree")
("ptid" . "application/vnd.pvi.ptid1")
("qxd" . "application/vnd.quark.quarkxpress")
("bed" . "application/vnd.realvnc.bed")
("mxl" . "application/vnd.recordare.musicxml")
("musicxml" . "application/vnd.recordare.musicxml+xml")
("cryptonote" . "application/vnd.rig.cryptonote")
("cod" . "application/vnd.rim.cod")
("rm" . "application/vnd.rn-realmedia")
("rmvb" . "application/vnd.rn-realmedia-vbr")
("link66" . "application/vnd.route66.link66+xml")
("st" . "application/vnd.sailingtracker.track")
("see" . "application/vnd.seemail")
("sema" . "application/vnd.sema")
("semd" . "application/vnd.semd")
("semf" . "application/vnd.semf")
("ifm" . "application/vnd.shana.informed.formdata")
("itp" . "application/vnd.shana.informed.formtemplate")
("iif" . "application/vnd.shana.informed.interchange")
("ipk" . "application/vnd.shana.informed.package")
("twd" . "application/vnd.simtech-mindmapper")
("mmf" . "application/vnd.smaf")
("teacher" . "application/vnd.smart.teacher")
("sdkm" . "application/vnd.solent.sdkm+xml")
("dxp" . "application/vnd.spotfire.dxp")
("sfs" . "application/vnd.spotfire.sfs")
("sdc" . "application/vnd.stardivision.calc")
("sda" . "application/vnd.stardivision.draw")
("sdd" . "application/vnd.stardivision.impress")
("smf" . "application/vnd.stardivision.math")
("sdw" . "application/vnd.stardivision.writer")
("sgl" . "application/vnd.stardivision.writer-global")
("smzip" . "application/vnd.stepmania.package")
("sm" . "application/vnd.stepmania.stepchart")
("sxc" . "application/vnd.sun.xml.calc")
("stc" . "application/vnd.sun.xml.calc.template")
("sxd" . "application/vnd.sun.xml.draw")
("std" . "application/vnd.sun.xml.draw.template")
("sxi" . "application/vnd.sun.xml.impress")
("sti" . "application/vnd.sun.xml.impress.template")
("sxm" . "application/vnd.sun.xml.math")
("sxw" . "application/vnd.sun.xml.writer")
("sxg" . "application/vnd.sun.xml.writer.global")
("stw" . "application/vnd.sun.xml.writer.template")
("sus" . "application/vnd.sus-calendar")
("svd" . "application/vnd.svd")
("sis" . "application/vnd.symbian.install")
("xsm" . "application/vnd.syncml+xml")
("bdm" . "application/vnd.syncml.dm+wbxml")
("xdm" . "application/vnd.syncml.dm+xml")
("tao" . "application/vnd.tao.intent-module-archive")
("pcap" . "application/vnd.tcpdump.pcap")
("tmo" . "application/vnd.tmobile-livetv")
("tpt" . "application/vnd.trid.tpt")
("mxs" . "application/vnd.triscape.mxs")
("tra" . "application/vnd.trueapp")
("ufd" . "application/vnd.ufdl")
("utz" . "application/vnd.uiq.theme")
("umj" . "application/vnd.umajin")
("unityweb" . "application/vnd.unity")
("uoml" . "application/vnd.uoml+xml")
("vcx" . "application/vnd.vcx")
("vsd" . "application/vnd.visio")
("vis" . "application/vnd.visionary")
("vsf" . "application/vnd.vsf")
("wbxml" . "application/vnd.wap.wbxml")
("wmlc" . "application/vnd.wap.wmlc")
("wmlsc" . "application/vnd.wap.wmlscriptc")
("wtb" . "application/vnd.webturbo")
("nbp" . "application/vnd.wolfram.player")
("wpd" . "application/vnd.wordperfect")
("wqd" . "application/vnd.wqd")
("stf" . "application/vnd.wt.stf")
("xar" . "application/vnd.xara")
("xfdl" . "application/vnd.xfdl")
("hvd" . "application/vnd.yamaha.hv-dic")
("hvs" . "application/vnd.yamaha.hv-script")
("hvp" . "application/vnd.yamaha.hv-voice")
("osf" . "application/vnd.yamaha.openscoreformat")
("osfpvg" . "application/vnd.yamaha.openscoreformat.osfpvg+xml")
("saf" . "application/vnd.yamaha.smaf-audio")
("spf" . "application/vnd.yamaha.smaf-phrase")
("cmp" . "application/vnd.yellowriver-custom-menu")
("zir" . "application/vnd.zul")
("zaz" . "application/vnd.zzazz.deck+xml")
("vxml" . "application/voicexml+xml")
("wgt" . "application/widget")
("hlp" . "application/winhlp")
("wsdl" . "application/wsdl+xml")
("wspolicy" . "application/wspolicy+xml")
("7z" . "application/x-7z-compressed")
("abw" . "application/x-abiword")
("ace" . "application/x-ace-compressed")
("dmg" . "application/x-apple-diskimage")
("aab" . "application/x-authorware-bin")
("aam" . "application/x-authorware-map")
("aas" . "application/x-authorware-seg")
("bcpio" . "application/x-bcpio")
("torrent" . "application/x-bittorrent")
("blb" . "application/x-blorb")
("bz" . "application/x-bzip")
("bz2" . "application/x-bzip2")
("cbr" . "application/x-cbr")
("vcd" . "application/x-cdlink")
("cfs" . "application/x-cfs-compressed")
("chat" . "application/x-chat")
("pgn" . "application/x-chess-pgn")
("nsc" . "application/x-conference")
("cpio" . "application/x-cpio")
("csh" . "application/x-csh")
("deb" . "application/x-debian-package")
("dgc" . "application/x-dgc-compressed")
("dir" . "application/x-director")
("wad" . "application/x-doom")
("ncx" . "application/x-dtbncx+xml")
("dtb" . "application/x-dtbook+xml")
("res" . "application/x-dtbresource+xml")
("dvi" . "application/x-dvi")
("evy" . "application/x-envoy")
("eva" . "application/x-eva")
("bdf" . "application/x-font-bdf")
("gsf" . "application/x-font-ghostscript")
("psf" . "application/x-font-linux-psf")
("otf" . "application/x-font-otf")
("pcf" . "application/x-font-pcf")
("snf" . "application/x-font-snf")
("ttf" . "application/x-font-ttf")
("pfa" . "application/x-font-type1")
("woff" . "application/x-font-woff")
("arc" . "application/x-freearc")
("spl" . "application/x-futuresplash")
("gca" . "application/x-gca-compressed")
("ulx" . "application/x-glulx")
("gnumeric" . "application/x-gnumeric")
("gramps" . "application/x-gramps-xml")
("gtar" . "application/x-gtar")
("hdf" . "application/x-hdf")
("install" . "application/x-install-instructions")
("iso" . "application/x-iso9660-image")
("jnlp" . "application/x-java-jnlp-file")
("latex" . "application/x-latex")
("lzh" . "application/x-lzh-compressed")
("mie" . "application/x-mie")
("prc" . "application/x-mobipocket-ebook")
("m3u8" . "application/x-mpegurl")
("application" . "application/x-ms-application")
("lnk" . "application/x-ms-shortcut")
("wmd" . "application/x-ms-wmd")
("wmz" . "application/x-ms-wmz")
("xbap" . "application/x-ms-xbap")
("mdb" . "application/x-msaccess")
("obd" . "application/x-msbinder")
("crd" . "application/x-mscardfile")
("clp" . "application/x-msclip")
("exe" . "application/x-msdownload")
("mvb" . "application/x-msmediaview")
("wmf" . "application/x-msmetafile")
("mny" . "application/x-msmoney")
("pub" . "application/x-mspublisher")
("scd" . "application/x-msschedule")
("trm" . "application/x-msterminal")
("wri" . "application/x-mswrite")
("nc" . "application/x-netcdf")
("nzb" . "application/x-nzb")
("p12" . "application/x-pkcs12")
("p7b" . "application/x-pkcs7-certificates")
("p7r" . "application/x-pkcs7-certreqresp")
("rar" . "application/x-rar-compressed")
("ris" . "application/x-research-info-systems")
("sh" . "application/x-sh")
("shar" . "application/x-shar")
("swf" . "application/x-shockwave-flash")
("xap" . "application/x-silverlight-app")
("sql" . "application/x-sql")
("sit" . "application/x-stuffit")
("sitx" . "application/x-stuffitx")
("srt" . "application/x-subrip")
("sv4cpio" . "application/x-sv4cpio")
("sv4crc" . "application/x-sv4crc")
("t3" . "application/x-t3vm-image")
("gam" . "application/x-tads")
("tar" . "application/x-tar")
("tcl" . "application/x-tcl")
("tex" . "application/x-tex")
("tfm" . "application/x-tex-tfm")
("texinfo" . "application/x-texinfo")
("obj" . "application/x-tgif")
("ustar" . "application/x-ustar")
("src" . "application/x-wais-source")
("der" . "application/x-x509-ca-cert")
("fig" . "application/x-xfig")
("xlf" . "application/x-xliff+xml")
("xpi" . "application/x-xpinstall")
("xz" . "application/x-xz")
("z1" . "application/x-zmachine")
("xaml" . "application/xaml+xml")
("xdf" . "application/xcap-diff+xml")
("xenc" . "application/xenc+xml")
("xhtml" . "application/xhtml+xml")
("xml" . "application/xml")
("dtd" . "application/xml-dtd")
("xop" . "application/xop+xml")
("xpl" . "application/xproc+xml")
("xslt" . "application/xslt+xml")
("xspf" . "application/xspf+xml")
("mxml" . "application/xv+xml")
("yang" . "application/yang")
("yin" . "application/yin+xml")
("zip" . "application/zip")
("adp" . "audio/adpcm")
("au" . "audio/basic")
("mid" . "audio/midi")
("mp4a" . "audio/mp4")
("m4a" . "audio/mp4a-latm")
("mpga" . "audio/mpeg")
("oga" . "audio/ogg")
("s3m" . "audio/s3m")
("sil" . "audio/silk")
("uva" . "audio/vnd.dece.audio")
("eol" . "audio/vnd.digital-winds")
("dra" . "audio/vnd.dra")
("dts" . "audio/vnd.dts")
("dtshd" . "audio/vnd.dts.hd")
("lvp" . "audio/vnd.lucent.voice")
("pya" . "audio/vnd.ms-playready.media.pya")
("ecelp4800" . "audio/vnd.nuera.ecelp4800")
("ecelp7470" . "audio/vnd.nuera.ecelp7470")
("ecelp9600" . "audio/vnd.nuera.ecelp9600")
("rip" . "audio/vnd.rip")
("weba" . "audio/webm")
("aac" . "audio/x-aac")
("aif" . "audio/x-aiff")
("caf" . "audio/x-caf")
("flac" . "audio/x-flac")
("mka" . "audio/x-matroska")
("m3u" . "audio/x-mpegurl")
("wax" . "audio/x-ms-wax")
("wma" . "audio/x-ms-wma")
("ram" . "audio/x-pn-realaudio")
("rmp" . "audio/x-pn-realaudio-plugin")
("wav" . "audio/x-wav")
("xm" . "audio/xm")
("cdx" . "chemical/x-cdx")
("cif" . "chemical/x-cif")
("cmdf" . "chemical/x-cmdf")
("cml" . "chemical/x-cml")
("csml" . "chemical/x-csml")
("xyz" . "chemical/x-xyz")
("bmp" . "image/bmp")
("cgm" . "image/cgm")
("g3" . "image/g3fax")
("gif" . "image/gif")
("ief" . "image/ief")
("jp2" . "image/jp2")
("jpeg" . "image/jpeg")
("ktx" . "image/ktx")
("pict" . "image/pict")
("png" . "image/png")
("btif" . "image/prs.btif")
("sgi" . "image/sgi")
("svg" . "image/svg+xml")
("tiff" . "image/tiff")
("psd" . "image/vnd.adobe.photoshop")
("uvi" . "image/vnd.dece.graphic")
("sub" . "image/vnd.dvb.subtitle")
("djvu" . "image/vnd.djvu")
("dwg" . "image/vnd.dwg")
("dxf" . "image/vnd.dxf")
("fbs" . "image/vnd.fastbidsheet")
("fpx" . "image/vnd.fpx")
("fst" . "image/vnd.fst")
("mmr" . "image/vnd.fujixerox.edmics-mmr")
("rlc" . "image/vnd.fujixerox.edmics-rlc")
("mdi" . "image/vnd.ms-modi")
("wdp" . "image/vnd.ms-photo")
("npx" . "image/vnd.net-fpx")
("wbmp" . "image/vnd.wap.wbmp")
("xif" . "image/vnd.xiff")
("webp" . "image/webp")
("3ds" . "image/x-3ds")
("ras" . "image/x-cmu-raster")
("cmx" . "image/x-cmx")
("fh" . "image/x-freehand")
("ico" . "image/x-icon")
("pntg" . "image/x-macpaint")
("sid" . "image/x-mrsid-image")
("pcx" . "image/x-pcx")
("pic" . "image/x-pict")
("pnm" . "image/x-portable-anymap")
("pbm" . "image/x-portable-bitmap")
("pgm" . "image/x-portable-graymap")
("ppm" . "image/x-portable-pixmap")
("qtif" . "image/x-quicktime")
("rgb" . "image/x-rgb")
("tga" . "image/x-tga")
("xbm" . "image/x-xbitmap")
("xpm" . "image/x-xpixmap")
("xwd" . "image/x-xwindowdump")
("eml" . "message/rfc822")
("igs" . "model/iges")
("msh" . "model/mesh")
("dae" . "model/vnd.collada+xml")
("dwf" . "model/vnd.dwf")
("gdl" . "model/vnd.gdl")
("gtw" . "model/vnd.gtw")
("mts" . "model/vnd.mts")
("vtu" . "model/vnd.vtu")
("wrl" . "model/vrml")
("x3db" . "model/x3d+binary")
("x3dv" . "model/x3d+vrml")
("x3d" . "model/x3d+xml")
("manifest" . "text/cache-manifest")
("appcache" . "text/cache-manifest")
("ics" . "text/calendar")
("css" . "text/css")
("csv" . "text/csv")
("html" . "text/html")
("n3" . "text/n3")
("txt" . "text/plain")
("dsc" . "text/prs.lines.tag")
("rtx" . "text/richtext")
("sgml" . "text/sgml")
("tsv" . "text/tab-separated-values")
("t" . "text/troff")
("ttl" . "text/turtle")
("uri" . "text/uri-list")
("vcard" . "text/vcard")
("curl" . "text/vnd.curl")
("dcurl" . "text/vnd.curl.dcurl")
("scurl" . "text/vnd.curl.scurl")
("mcurl" . "text/vnd.curl.mcurl")
("sub" . "text/vnd.dvb.subtitle")
("fly" . "text/vnd.fly")
("flx" . "text/vnd.fmi.flexstor")
("gv" . "text/vnd.graphviz")
("3dml" . "text/vnd.in3d.3dml")
("spot" . "text/vnd.in3d.spot")
("jad" . "text/vnd.sun.j2me.app-descriptor")
("wml" . "text/vnd.wap.wml")
("wmls" . "text/vnd.wap.wmlscript")
("s" . "text/x-asm")
("c" . "text/x-c")
("f" . "text/x-fortran")
("java" . "text/x-java-source")
("opml" . "text/x-opml")
("p" . "text/x-pascal")
("nfo" . "text/x-nfo")
("etx" . "text/x-setext")
("sfv" . "text/x-sfv")
("uu" . "text/x-uuencode")
("vcs" . "text/x-vcalendar")
("vcf" . "text/x-vcard")
("3gp" . "video/3gpp")
("3g2" . "video/3gpp2")
("h261" . "video/h261")
("h263" . "video/h263")
("h264" . "video/h264")
("jpgv" . "video/jpeg")
("jpm" . "video/jpm")
("mj2" . "video/mj2")
("ts" . "video/mp2t")
("mp4" . "video/mp4")
("mpeg" . "video/mpeg")
("ogv" . "video/ogg")
("qt" . "video/quicktime")
("uvh" . "video/vnd.dece.hd")
("uvm" . "video/vnd.dece.mobile")
("uvp" . "video/vnd.dece.pd")
("uvs" . "video/vnd.dece.sd")
("uvv" . "video/vnd.dece.video")
("dvb" . "video/vnd.dvb.file")
("fvt" . "video/vnd.fvt")
("mxu" . "video/vnd.mpegurl")
("pyv" . "video/vnd.ms-playready.media.pyv")
("uvu" . "video/vnd.uvvu.mp4")
("viv" . "video/vnd.vivo")
("dv" . "video/x-dv")
("webm" . "video/webm")
("f4v" . "video/x-f4v")
("fli" . "video/x-fli")
("flv" . "video/x-flv")
("m4v" . "video/x-m4v")
("mkv" . "video/x-matroska")
("mng" . "video/x-mng")
("asf" . "video/x-ms-asf")
("vob" . "video/x-ms-vob")
("wm" . "video/x-ms-wm")
("wmv" . "video/x-ms-wmv")
("wmx" . "video/x-ms-wmx")
("wvx" . "video/x-ms-wvx")
("avi" . "video/x-msvideo")
("movie" . "video/x-sgi-movie")
("smv" . "video/x-smv")
("ice" . "x-conference/x-cooltalk")))

(use srfi-19)
(use test)
;;(use format)
(use regex)
;(declare (unit wwdate))
;; utility procedures to convert among
;; different ways to express date (wwdate, seconds since epoch, isodate)
;;
;; samples:
;; isodate   -> "2016-01-01"
;; wwdate -> "16ww01.5"
;; seconds   -> 1451631600

;; procedures provided:
;; ====================
;; seconds->isodate
;; seconds->wwdate
;;
;; isodate->seconds
;; isodate->wwdate
;;
;; wwdate->seconds
;; wwdate->isodate

;; srfi-19 used extensively; this doc is better tha the eggref:
;; http://srfi.schemers.org/srfi-19/srfi-19.html

;; Author: brandon.j.barclay@intel.com 16ww18.6

(define (date->seconds date)
  (inexact->exact
   (string->number
    (date->string date "~s"))))

(define (seconds->isodate seconds)
  (let* ((date (seconds->date seconds))
         (result (date->string date "~Y-~m-~d")))
    result))

(define (isodate->seconds isodate)
  "Takes a string input of the form 'YY-MM-DD' or 'YYYY-MM-DD' and returns epoch time; for YY, assume after Y2K"
  (let* ((numlist (map string->number (string-split isodate "-")))
        (raw-year (car numlist))
        (year (if (< raw-year 100) (+ raw-year 2000) raw-year))
        (month (list-ref numlist 1))
        (day (list-ref numlist 2))
        (date (make-date 0 0 0 0 day month year))
        (seconds (date->seconds date)))

    seconds))

;; adapted from perl Intel::WorkWeek perl module
;; workweek year consists of numbered weeks starting from week 1
;;   days of week are numbered starting from 0 on sunday
;;   weeks begin on sunday- day number 0 and end saturday- day 6
;;   week 1 is defined as the week containing jan 1 of the year
;;   workweek year does not match calendar year in workweek 1
;;     since workweek 1 contains jan1 and workweek begins sunday,
;;     days prior to jan1 in workweek 1 belong to the next workweek year
(define (seconds->wwdate-values seconds)
  (define (date-difference->seconds d1 d2)
    (- (date->seconds d1) (date->seconds d2)))

  (let* ((thisdate (seconds->date seconds))
         (thisdow (string->number (date->string thisdate "~w")))

         (year (date-year thisdate))
         ;; intel workweek 1 begins on sunday of week containing jan1
         (jan1 (make-date 0 0 0 0 1 1 year))
         (jan1dow (date-week-day jan1))
         (ww01 (date-subtract-duration jan1 (seconds->time (* 60 60 24 jan1dow))))

         (ww01_delta_seconds (date-difference->seconds thisdate ww01))
         (wwnum_initial (inexact->exact (add1 (floor (/ ww01_delta_seconds 24 3600 7) ))))
         
         ;; we could be in ww1 of next year
         (this-saturday (seconds->date
                         (+ seconds
                            (* 60 60 24 (- 6 thisdow)))))
         (this-week-ends-next-year?
          (> (date-year this-saturday) year))
         (intelyear
          (if this-week-ends-next-year?
              (add1 year)
              year))
         (intelweek
          (if this-week-ends-next-year?
              1
              wwnum_initial)))
   (values intelyear intelweek thisdow)))

(define (string-leftpad in width pad-char)
  (let* ((unpadded-str (->string in))
         (padlen_temp (- width (string-length unpadded-str)))
         (padlen (if (< padlen_temp 0) 0 padlen_temp))
         (padding (make-string padlen pad-char)))
    (conc padding unpadded-str)))

(define (string-rightpad in width pad-char)
  (let* ((unpadded-str (->string in))
         (padlen_temp (- width (string-length unpadded-str)))
         (padlen (if (< padlen_temp 0) 0 padlen_temp))
         (padding (make-string padlen pad-char)))
    (conc unpadded-str padding)))

(define (zeropad num width)
  (string-leftpad num width #\0))

(define (seconds->wwdate seconds)

  (let-values (((intelyear intelweek day-of-week-num)
                (seconds->wwdate-values seconds)))
    (let ((intelyear-str
           (zeropad
            (->string
             (if (> intelyear 1999)
                 (- intelyear 2000) intelyear))
            2))
          (intelweek-str
           (zeropad (->string intelweek) 2))
          (dow-str (->string day-of-week-num)))
      (conc intelyear-str "ww" intelweek-str "." dow-str))))

(define (isodate->wwdate isodate)
  (seconds->wwdate
   (isodate->seconds isodate)))

(define (wwdate->seconds wwdate)
  (let ((match (string-match "^(\\d+)ww(\\d+).(\\d)$" wwdate)))
    (if
     (not match)
     #f
     (let* (
            (intelyear-raw (string->number (list-ref match 1)))
            (intelyear (if (< intelyear-raw 100)
                           (+ intelyear-raw 2000)
                           intelyear-raw))
            (intelww (string->number (list-ref match 2)))
            (dayofweek (string->number (list-ref match 3)))

            (day-of-seconds (* 60 60 24 ))
            (week-of-seconds (* day-of-seconds 7))
            

            ;; get seconds at ww1.0
            (new-years-date (make-date 0 0 0 0 1 1 intelyear))
            (new-years-seconds
             (date->seconds new-years-date))
            (new-years-dayofweek (date-week-day new-years-date))
            (ww1.0_seconds (- new-years-seconds
                              (* day-of-seconds
                                 new-years-dayofweek)))
            (workweek-adjustment (* week-of-seconds (sub1 intelww)))
            (weekday-adjustment (* dayofweek day-of-seconds))

            (result (+ ww1.0_seconds workweek-adjustment weekday-adjustment)))
       result))))

(define (wwdate->isodate wwdate)
  (seconds->isodate (wwdate->seconds wwdate)))

(define (current-wwdate)
  (seconds->wwdate (current-seconds)))

(define (current-isodate)
  (seconds->isodate (current-seconds)))

(define (wwdate-tests)
  (test-group
   "date conversion tests"
   (let ((test-table
          '(("16ww01.5" . "2016-01-01")
            ("16ww18.5" . "2016-04-29")
            ("1999ww33.5" . "1999-08-13")
            ("16ww18.4" . "2016-04-28")
            ("16ww18.3" . "2016-04-27")
            ("13ww01.0" . "2012-12-30")
            ("13ww52.6" . "2013-12-28")
            ("16ww53.3" . "2016-12-28"))))
     (for-each
      (lambda (test-pair)
        (let ((wwdate (car test-pair))
              (isodate (cdr test-pair)))
          (test
           (conc "(isodate->wwdate "isodate ") => "wwdate)
           wwdate
           (isodate->wwdate isodate))
          
          (test
           (conc "(wwdate->isodate "wwdate ")   => "isodate)
           isodate
           (wwdate->isodate wwdate))))
      test-table))))


(define (ext->mimetype ext)
  (let ((x (assoc ext ducttape_ext2mimetype)))
   (if x (cdr x) "text/plain")))

  
  (define ducttape-lib-version 1.00)
  (define (toplevel-command sym proc) (lambda () #f))

  ;; like shell "which" command
  (define (find-exe exe)
    (let* ((path-items
            (string-split
             (or
              (get-environment-variable "PATH") "")
             ":")))

      (let loop ((rest-path-items path-items))
        (if (null? rest-path-items)
            #f
            (let* ((this-dir (car rest-path-items))
                   (next-rest (cdr rest-path-items))
                   (candidate (conc this-dir "/" exe)))
              (if (file-execute-access? candidate)
                  candidate
                  (loop next-rest)))))))


  
;;;; define some handy globals
  ;; resolve fullpath to this script or binary.
  (define (__get-this-script-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)))
              (caddr argv))
             (else (car argv))))
           
           ;;(foo (begin (print "hello "(find-exe "/bin/sh") #f)))
           (fullpath (or (find-exe this-script) (realpath this-script))))
      fullpath))
  
  (define *this-exe-fullpath* (__get-this-script-fullpath))
  (define *this-exe-dir*      (pathname-directory *this-exe-fullpath*))
  (define *this-exe-name*     (pathname-strip-directory *this-exe-fullpath*))
  

;;;; utility procedures


  
  ;; begin credit: megatest's process.scm
  (define (port->list fh )
    (if (eof-object? fh) #f
        (let loop ((curr (read-line fh))
                   (result '()))
          (if (not (eof-object? curr))
              (loop (read-line fh)
                    (append result (list curr)))
              result))))

  (define (conservative-read port)
    (let loop ((res ""))
      (if (not (eof-object? (peek-char port)))
          (loop (conc res (read-char port)))
          res)))
  ;; end credit: megatest's process.scm

  (define (counter-maker)
    (let ((acc 0))
      (lambda ( #!optional (increment 1) )
        (set! acc (+ increment acc))
        acc)))

  (define (port->string port #!optional ) ; todo - add newline 
    (let ((linelist (port->list port)))
      (if linelist
          (string-join linelist "\n")
          "")))


  (define (outport->foreach outport foreach-thunk)
    (let loop ((line (foreach-thunk)))
      (if line
          (begin
            (write-line line outport)
            (loop (foreach-thunk))
            )
          (begin
            ;;http://bugs.call-cc.org/ticket/766
            ;;close-[input|output]-port implicitly calling process-wait on process pipe ports. This leads to errors like
            ;;Error: (process-wait) waiting for child process failed - No child processes: 10872
            (close-output-port outport)
            #f))))
  
  ;; weird - alist-ref arg order changes signature csc vs. csi... explitly defining.
  (define (my-alist-ref key alist)
    (let ((res (assoc key alist)))
      (if res (cdr res) #f)))

  (define (keyword-skim-alist args alist)
    (let loop ((result-alist '()) (result-args args) (rest-alist alist))
      (cond
       ((null? rest-alist) (values result-alist result-args))
       (else
        (let ((keyword (caar rest-alist))
              (defval (cdar rest-alist)))
          (let-values (((kwval result-args2)
                        (keyword-skim
                         keyword
                         defval
                         result-args)))
            (loop
             (cons (cons keyword kwval) result-alist)
             result-args2
             (cdr rest-alist))))))))
  
  (define (isys command . rest-args)
    (let-values
        (((opt-alist args)
          (keyword-skim-alist
           rest-args
           '( ( foreach-stdout-thunk: . #f )
              ( foreach-stdin-thunk: . #f )
              ( stdin-proc: . #f ) ) )))
      (let* ((foreach-stdout-thunk
              (my-alist-ref foreach-stdout-thunk: opt-alist))
             (foreach-stdin-thunk
              (my-alist-ref foreach-stdin-thunk: opt-alist))
             (stdin-proc
              (if foreach-stdin-thunk
                  (lambda (port)
                    (outport->foreach port foreach-stdin-thunk))
                  (my-alist-ref stdin-proc: opt-alist))))

        ;; TODO: support command is list.
        
        (let-values (((stdout stdin pid stderr)
                      (if (null? args)
                          (process* command)
                          (process* command args))))
          
                                        ;(if foreach-stdin-thunk
                                        ;    (set! stdin-proc
                                        ;          (lambda (port)
                                        ;            (outport->foreach port foreach-stdin-thunk))))
          
          (if stdin-proc
              (stdin-proc stdin))
          
          (let ((stdout-res 
                 (if foreach-stdout-thunk  ;; don't accumulate stdout if we have a thunk; probably doing this because stdout is BIG so lets not waste memory
                     (begin
                       (port-for-each foreach-stdout-thunk (lambda () (read-line stdout)))
                       "foreach-stdout-thunk ate stdout"
                       )
                     (if stdin-proc
                         "foreach-stdin-thunk/stdin-proc blocks stdout"
                         (port->string stdout))))
                (stderr-res
                 (if stdin-proc
                     "foreach-stdin-thunk/stdin-proc blocks stdout"
                     (port->string stderr))))

            ;; if we've used a stdin-proc, we've closed stdin port, which unfortunately causes a wait-pid internally, causing stdout and stderr ports to auto-close.  don't close them again.  (so sad - we lost stdout and stderr contents when we write to stdin)
            ;; see - http://bugs.call-cc.org/ticket/766
            (if (not stdin-proc)
                (close-input-port stdout)
                (close-input-port stderr))
            
            (let-values (((anotherpid normalexit? exitstatus)  (process-wait pid)))
              (values exitstatus stdout-res stderr-res)))))))
  
  (define (do-or-die command   #!key nodie (foreach-stdout #f) (stdin-proc #f))
    (let-values (((exit-code stdout-str stderr-str) (isys command foreach-stdout-thunk: foreach-stdout stdin-proc: stdin-proc )))
      (if (equal? 0 exit-code)
          stdout-str
          (begin
            (ierr (conc "Command  > " command " "  "< failed with " exit-code " because: \n" stderr-str) )
            (if nodie #f (exit exit-code))))))


  ;; runs-ok: evaluate expression while suppressing exceptions.
                                        ;    on caught exception, returns #f
                                        ;    otherwise, returns expression value
  (define (runs-ok thunk)
    (handle-exceptions exn #f (begin (thunk) #t)))

  ;; concat-lists: result list = lista + listb
  (define (concat-lists lista listb) ;; ok, I just reimplemented append...
    (foldr cons listb lista))
  

;;; setup general_lib env var parameters

  ;; show warning/note/error/debug prefixes using ansi colors
  (define ducttape-color-mode
    (make-parameter (get-environment-variable "DUCTTAPE_COLORIZE")))

  ;; if defined, has number value.  if number value > 0, show debug messages
  ;; value should be decremented in subshells -- idea is raising debug level will show debug messages deeper and deeper in process call stack
  (define ducttape-debug-level
    (make-parameter
     (let ( (raw-debug-level (get-environment-variable "DUCTTAPE_DEBUG_LEVEL")) )
       (if raw-debug-level
           (let ((num-debug-level (runs-ok (string->number raw-debug-level))))
             (if (integer? num-debug-level)
                 (begin
                   (let ((new-num-debug-level (- num-debug-level 1)))
                     (if (> new-num-debug-level 0) ;; decrement
                         (setenv "DUCTTAPE_DEBUG_LEVEL" (number->string new-num-debug-level))
                         (unsetenv "DUCTTAPE_DEBUG_LEVEL")))
                   num-debug-level) ; it was set and > 0, mode is value
                 (begin
                   (unsetenv "DUCTTAPE_DEBUG_LEVEL") ;; value was invalid, unset it
                   #f))) ; value was invalid, mode is f
           #f)))) ; var not set, mode is f


  (define ducttape-debug-mode (if (ducttape-debug-level)  #t  #f))

  ;; ducttape-debug-regex-filter suppresses non-matching debug messages
  (define ducttape-debug-regex-filter
    (make-parameter
     (let ((raw-debug-pattern (get-environment-variable "DUCTTAPE_DEBUG_PATTERN")))
       (if raw-debug-pattern
           raw-debug-pattern
           "."))))

  ;; silent mode suppresses Note and Warning type messages
  (define ducttape-silent-mode
    (make-parameter (get-environment-variable "DUCTTAPE_SILENT_MODE")))

  ;; quiet mode suppresses Note type messages
  (define ducttape-quiet-mode
    (make-parameter (get-environment-variable "DUCTTAPE_QUIET_MODE")))

  ;; if log file is defined, warning/note/error/debug messages are appended
  ;; to named logfile.
  (define ducttape-log-file
    (make-parameter (get-environment-variable "DUCTTAPE_LOG_FILE")))




  
  
;;; standard messages printing implementation

                                        ; get the name of the current script/binary being run
  (define (script-name)
    (car (reverse (string-split (car (argv)) "/"))))

  (define (ducttape-timestamp)
    (rfc3339->string (time->rfc3339 (seconds->local-time))))


  (define (iputs-preamble msg-type #!optional (suppress-color #f))
    (let ((do-color (and
                     (not suppress-color)
                     (ducttape-color-mode)
                     (terminal-port? (current-error-port)))))
      (case msg-type
        ((note)
         (if do-color
             (set-text (list 'fg-green 'bg-black 'bold) "Note:")
             "Note:"
             ))
        ((warn)
         (if do-color
             (set-text (list 'fg-yellow 'bg-black 'bold) "Warning:")
             "Warning:"
             ))
        ((err)
         (if do-color
             (set-text (list 'fg-red 'bg-black 'bold) "Error:")
             "Error:"
             ))
        ((dbg)
         (if do-color
             (set-text (list 'fg-blue 'bg-magenta) "Debug:")
             "Debug:"
             )))))

  (define (ducttape-append-logfile msg-type message #!optional (suppress-preamble #f))
    (let
        ((txt 
          (string-join 
           (list 
            (ducttape-timestamp) 
            (script-name)
            (if suppress-preamble
                message
                (string-join  (list (iputs-preamble msg-type #t) message) " ")))
           " | ")))

      (if (ducttape-log-file)
          (runs-ok
           (call-with-output-file (ducttape-log-file)
             (lambda (output-port)
               (format output-port "~A ~%" txt)
               )
             #:append))
          #t)))

  (define (ducttape-activate-logfile #!optional (logfile #f))
    ;; from python ducttape-lib.py
                                        ; message = "START - pid=%d ppid=%d argv=(%s) pwd=%s user=%s host=%s"%(pid,ppid," ".join("'"+x+"'" for x in sys.argv),os.environ['PWD'],os.getenv('USER','nouser'),os.getenv('HOST','nohost') )
    (let ((pid (number->string (current-process-id)))
          (ppid (number->string (parent-process-id)))
          (argv 
           (string-join 
            (map 
             (lambda (x) 
               (string-join (list "\"" x "\"")  "" ))
             (argv))
            " "))
          (pwd (or (get-environment-variable "PWD") "nopwd"))
          (user (or (get-environment-variable "USER") "nouser"))
          (host (or (get-environment-variable "HOST") "nohost")))
      (if logfile
          (begin
            (ducttape-log-file logfile)
            (setenv "DUCTTAPE_LOG_FILE" (ducttape-log-file))))
      (ducttape-append-logfile 'note (format #f "START - pid=~A ppid=~A argv=(~A) pwd=~A user=~A host=~A" pid ppid argv pwd user host) #t)))         


  ;; log exit code
  (define (set-ducttape-log-exit-handler)
    (let ((orig-exit-handler (exit-handler)))
      (exit-handler 
       (lambda (exitcode) 
         (ducttape-append-logfile 'note (format #f "Exit ~A by sys.exit" exitcode) #t)
         (orig-exit-handler exitcode)))))


  (define (idbg first-message  . rest-args)
    (let* ((debug-level-threshold
            (if (> (length rest-args) 0) (car rest-args) 1))
           (message-list
            (if (> (length rest-args) 1)
                (cons first-message (cdr rest-args))
                (list first-message)) )
           (message (apply conc
                  (map ->string message-list))))

      (ducttape-append-logfile 'dbg message)
      (if (ducttape-debug-level)
          (if (<= debug-level-threshold (ducttape-debug-level))
              (if (string-search (ducttape-debug-regex-filter) message)
                  (begin 
                    (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'dbg) message (script-name))))))))

  (define (ierr message-first  . message-rest)
    (let* ((message
            (apply conc
             (map ->string (cons message-first message-rest)))))
      (ducttape-append-logfile 'err message)
      (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'err) message (script-name))))

  (define (iwarn message-first  . message-rest)
    (let* ((message
            (apply conc
             (map ->string (cons message-first message-rest)))))
      (ducttape-append-logfile 'warn message)
      (if (not (ducttape-silent-mode))
          (begin
            (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'warn) message (script-name))))))

  (define (inote message-first  . message-rest)
    (let* ((message
            (apply conc
             (map ->string (cons message-first message-rest)))))
      (ducttape-append-logfile 'note message)
      (if (not (or (ducttape-silent-mode) (ducttape-quiet-mode)))
          (begin 
            (format (current-error-port) "~A ~A (~A)~%" (iputs-preamble 'note) message (script-name))))))

  
  (define (iputs kind message #!optional (debug-level-threshold 1))
    (cond
     ((member kind (string-split "NOTE/Note/note/n/N" "/")) (inote message))
     ((member kind (string-split "Error/ERROR/error/Err/ERR/err/E/e" "/")) (ierr message))
     ((member kind
              (string-split "Warning/WARNING/warning/Warn/WARN/warn/W/w" "/"))
      (iwarn message))
     ((member kind (string-split "Debug/DEBUG/debug/Dbg/DBG/dbg/D/d" "/"))
      (idbg message debug-level-threshold))))

  (define (mkdir-recursive path-so-far hier-list-to-create)
    (if (null? hier-list-to-create)
        path-so-far
        (let* ((next-hier-item (car hier-list-to-create))
               (rest-hier-items (cdr hier-list-to-create))
               (path-to-mkdir (string-concatenate (list path-so-far "/" next-hier-item))))
          (if (runs-ok (lambda () (create-directory path-to-mkdir)))
              (mkdir-recursive path-to-mkdir rest-hier-items)
              #f))))

                                        ; ::mkdir-if-not-exists::
                                        ; make a dir recursively if it does not 
                                        ; already exist.
                                        ; on success - returns path
                                        ; on fail - returns #f
  (define (mkdirp-if-not-exists the-dir)
    (let ( (path-list (string-split the-dir "/")))
      (mkdir-recursive "/" path-list)))

                                        ; ::mkdir-if-not-exists::
                                        ; make a dir recursively if it does not 
                                        ; already exist.
                                        ; on success - returns path
                                        ; on fail - returns #f


  (define (mkdirp-if-not-exists the-dir)
    (let ( (path-list (string-split the-dir "/")))
      (mkdir-recursive "/" path-list)))

  (define (dir-is-writable? the-dir)
    (let ((dummy-file (string-concatenate (list the-dir "/.dummyfile"))))
      (and
       (file-exists? the-dir)
       (cond 
        ((runs-ok (lambda ()(with-output-to-file dummy-file (lambda () (print "foo")))))
         (begin
           (runs-ok (lambda () (delete-file dummy-file) ))
           the-dir))
        (else #f)))))


  (define (get-tmpdir )
    (let* ((tmproot
            (dir-is-writable?
             (or 
              (get-environment-variable "TMPDIR") 
              "/tmp")))

           (user
            (or
             (get-environment-variable "USER")
             "USER_Envvar_not_set"))
           (tmppath
            (string-concatenate 
             (list tmproot "/env21-general-" user ))))

      (dir-is-writable?
       (mkdirp-if-not-exists
        tmppath))))

  (define (mktemp
           #!optional
           (prefix "general_lib_tmpfile")
           (dir #f))
    (let-values
        (((fd path) 
          (file-mkstemp 
           (conc 
            (if dir  dir  (get-tmpdir))
            "/" prefix ".XXXXXX"))))
      (close-output-port (open-output-file* fd))
      path))



  ;;http://stackoverflow.com/questions/11134857/using-sendmail-for-html-body-and-binary-attachment
  ;; write send-email using:
  ;;   - isys-foreach-stdin-line
  ;;   - formatting in http://stackoverflow.com/questions/11134857/using-sendmail-for-html-body-and-binary-attachment
  (define (sendmail to_addr subject body
                    #!key
                    (from_addr "admin")
                    cc_addr
                    bcc_addr
                    more-headers
                    use_html
                    (attach-files-list '())
                    (images-with-content-id-alist '())
                    )

    (define (sendmail-proc sendmail-port)
      (define (wl line-str)
        (write-line line-str sendmail-port))

      (define (get-uuid)
        (string-upcase (uuid->string (uuid-generate))))

      (let ((mailpart-uuid (get-uuid))
            (mailpart-body-uuid (get-uuid)))
        
        (define (boundary)
          (wl (conc "--" mailpart-uuid)))

        (define (body-boundary)
          (wl (conc "--" mailpart-body-uuid)))


        (define (email-mime-header)
          (wl (conc "From: " from_addr))
          (wl (conc "To: " to_addr))
          (if cc_addr
              (wl (conc "Cc: " cc_addr)))
          (if bcc_addr
              (wl (conc "Bcc: " bcc_addr)))
          (if more-headers
              (wl more-headers))
          (wl (conc "Subject: " subject))
          (wl "MIME-Version: 1.0")
          (wl (conc "Content-Type: multipart/mixed; boundary=\"" mailpart-uuid "\""))
          (wl "")
          (boundary)
          (wl (conc "Content-Type: multipart/alternative; boundary=\"" mailpart-body-uuid "\""))
          (wl "")
          )

        
        (define (email-text-body)
          (body-boundary)
          (wl "Content-Type: text/plain; charset=ISO-8859-1")
          (wl "Content-Disposition: inline")
          (wl "")
          (wl body)
          (body-boundary))
        
        (define (email-html-body)
          (body-boundary)
          (wl "Content-Type: text/plain; charset=ISO-8859-1")
          (wl "")
          (wl "You need to enable HTML option for email")
          (body-boundary)
          (wl "Content-Type: text/html; charset=ISO-8859-1")
          (wl "Content-Disposition: inline")
          (wl "")
          (wl body)
          (body-boundary))

        (define (attach-file file #!key (content-id #f))
          (let* ((filename
                  (filepath:take-file-name file))
                 (ext-with-dot
                  (filepath:take-extension file))
                 (ext (string-take-right
                       ext-with-dot
                       (- (string-length ext-with-dot) 1)))
                 (mimetype (ext->mimetype ext))
                 (uuencode-command (conc "uuencode " file " " filename)))
            (boundary)
            (wl (conc "Content-Type: " mimetype "; name=\"" filename "\""))
            (wl "Content-Transfer-Encoding: uuencode")
            (if content-id
                (wl (conc "Content-Id: " content-id)))
            (wl (conc "Content-Disposition: attachment; filename=\"" filename "\""))
            (wl "")
            (do-or-die
             uuencode-command
             foreach-stdout:
             (lambda (line)
               (wl line)))))

        (define (embed-image file+content-id)
          (let ((file (car file+content-id))
                (content-id (cdr file+content-id)))
            (attach-file file content-id: content-id)))
        
        ;; send the email
        (email-mime-header)
        (if use_html
            (email-html-body)
            (email-text-body))
        (for-each attach-file attach-files-list)
        (for-each embed-image images-with-content-id-alist)
        (boundary)
        (close-output-port sendmail-port)))
    
    (do-or-die "/usr/sbin/sendmail -t"
               stdin-proc: sendmail-proc))


;;;; process command line options

  ;; get command line switches (have no subsequent arg; eg. [-foo])
  ;;  assumes these are switches without arguments
  ;;  will return list of matches
  ;;  removes matches from command-line-arguments parameter
  (define (skim-cmdline-opts-noarg-by-regex switch-pattern)
    (let* (
           (irr (irregex switch-pattern))
           (matches (filter
                     (lambda (x)
                       (irregex-match irr x))
                     (command-line-arguments)))
           (non-matches (filter
                         (lambda (x)
                           (not (member x matches)))
                         (command-line-arguments))))

      (command-line-arguments non-matches)
      matches))

  (define (keyword-skim keyword default args #!optional (eqpred equal?))
    (let loop ( (kwval default) (args-remaining args) (args-to-return '()) )
      (cond 
       ((null? args-remaining)
        (values
         (if (list? kwval) (reverse kwval) kwval)
         (reverse args-to-return)))
       ((and (> (length args-remaining) 1) (eqpred keyword (car args-remaining)))
        (if (list? default)
            (if (equal? default kwval)
                (loop (list (cadr args-remaining)) (cddr args-remaining) args-to-return)
                (loop (cons (cadr args-remaining) kwval) (cddr args-remaining) args-to-return))
            (loop (cadr args-remaining) (cddr args-remaining) args-to-return)))
       (else (loop kwval (cdr args-remaining) (cons (car args-remaining) args-to-return))))))


  (define (get-cli-arg arg #!key (default #f) (is-list #f))
    (let* ((temp    (skim-cmdline-opts-withargs-by-regex arg)))
      (if (> (length temp) 0)
          (if is-list
              temp
              (car temp))
          default)))

  (define (get-cli-switch arg)
    (let ((temp (skim-cmdline-opts-noarg-by-regex arg)))
      (if (> (length temp) 0)
          (car temp)
          #f)))
  



  ;; get command line switches (have a subsequent arg; eg. [-foo bar])
  ;;  assumes these are switches without arguments
  ;;  will return list of arguments to matches
  ;;  removes matches from command-line-arguments parameter

  (define (re-match? re str)
    (irregex-match re str))

  (define (skim-cmdline-opts-withargs-by-regex switch-pattern)
    (let-values
        (((result new-cmdline-args)
          (keyword-skim switch-pattern
                        '()
                        (command-line-arguments)
                        re-match?
                        )))
      (command-line-arguments new-cmdline-args)
      result))
  
  

  ;; recognize ducttape-lib command line switches (--quiet, --silent, --color, -d.., -dp.., -logfile)
  ;;    - reset parameters; reset DUCTTAPE_* env vars to match user specified intent
  ;;    - mutate (command-line-arguments) parameter to subtract these recognized and handled switches
  ;;       * beware -- now (argv) and (command-line-arguments) are inconsistent... cannot mutate (argv) alas.  Use (command-line-arguments)
  ;; WARNING: this defines command line arguments that may clash with your program.  Only call this if you
  ;; are sure they can coexist.
  (define (ducttape-process-command-line)

    ;; --quiet
    (let ((quiet-opts (skim-cmdline-opts-noarg-by-regex "--?quiet")))
      (if (not (null? quiet-opts))
          (begin
            (setenv "DUCTTAPE_QUIET_MODE" "1")
            (ducttape-quiet-mode "1"))))

    ;; --silent
    (let ((silent-opts (skim-cmdline-opts-noarg-by-regex "--?silent")))
      (if (not (null? silent-opts))
          (begin
            (setenv "DUCTTAPE_SILENT_MODE" "1")
            (ducttape-silent-mode "1"))))

    ;; -color
    (let ((color-opts (skim-cmdline-opts-noarg-by-regex "--?colou?r(ize)?")))
      (if (not (null? color-opts))
          (begin
            (setenv "DUCTTAPE_COLORIZE" "1")
            (ducttape-color-mode "1"))))

    ;; -nocolor
    (let ((nocolor-opts (skim-cmdline-opts-noarg-by-regex "--?nocolou?r(ize)?")))
      (if (not (null? nocolor-opts))
          (begin
            (unsetenv "DUCTTAPE_COLORIZE" )
            (ducttape-color-mode #f))))

    ;; -logfile
    (let ((logfile-opts (skim-cmdline-opts-withargs-by-regex "--?log(-?file)?")))
      (if (not (null? logfile-opts))
          (begin
            (ducttape-log-file (car (reverse logfile-opts)))
            (setenv "DUCTTAPE_LOG_FILE" (ducttape-log-file)))))

    ;; -d -dd -d#
    (let ((debug-opts (skim-cmdline-opts-noarg-by-regex "-d(d*|\\d+)"))
          (initial-debuglevel (if (ducttape-debug-level) (ducttape-debug-level) 0) ))
      (if (not (null? debug-opts))
          (begin
            (ducttape-debug-level
             (let loop ((opts debug-opts) (debuglevel initial-debuglevel))
               (if (null? opts)
                   debuglevel
                   (let*
                       ( (curopt (car opts))
                         (restopts (cdr opts))
                         (ds (string-match "-(d+)" curopt))
                         (dnum (string-match "-d(\\d+)" curopt)))
                     (cond
                      (ds (loop restopts (+ debuglevel (string-length (cadr ds)))))
                      (dnum  (loop restopts (string->number (cadr dnum)))))))))
            (setenv "DUCTTAPE_DEBUG_LEVEL" (number->string (ducttape-debug-level))))))


    ;; -dp <pat> / --debug-pattern <pat>
    (let ((debugpat-opts (skim-cmdline-opts-withargs-by-regex "--?(debug-pattern|dp)")))
      (if (not (null? debugpat-opts))
          (begin
            (ducttape-debug-regex-filter (string-join debugpat-opts "|"))
            (setenv "DUCTTAPE_DEBUG_PATTERN" (ducttape-debug-regex-filter)))))) 


  ;;; following code commented out; side effects not wanted on startup
  ;; immediately activate logfile (will be noop if logfile disabled)
  ;;(ducttape-activate-logfile)
  ;;(set-ducttape-log-exit-handler)
  
  ;; TODO: hook exception handler so we can log exception before we sign off.

  ;; handle command line immediately; 
  ;;(process-command-line)                    


  ) ; end module








Added ducttape/ducttape-lib.setup version [f078cc60c2].





1

+

(standard-extension 'ducttape-lib '1.0.0)








Added ducttape/mimetypes.scm version [391fe0b393].


















































































































































































































































































































































































































































































































































































































































































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
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
227
228
229
230
231
232
233
234
235
236
237
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
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
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
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; gathered from macosx:
;;   cat /etc/apache2/mime.types | grep -v '^#' | perl -ne 'print "(\"$2\" . \"$1\")\n" if /(\S+)\s+(\S+)/' > mimetypes.scm
;; + manual manipulation

(define ducttape_ext2mimetype '(("ez" . "application/andrew-inset")
("aw" . "application/applixware")
("atom" . "application/atom+xml")
("atomcat" . "application/atomcat+xml")
("atomsvc" . "application/atomsvc+xml")
("ccxml" . "application/ccxml+xml")
("cdmia" . "application/cdmi-capability")
("cdmic" . "application/cdmi-container")
("cdmid" . "application/cdmi-domain")
("cdmio" . "application/cdmi-object")
("cdmiq" . "application/cdmi-queue")
("cu" . "application/cu-seeme")
("davmount" . "application/davmount+xml")
("dbk" . "application/docbook+xml")
("dssc" . "application/dssc+der")
("xdssc" . "application/dssc+xml")
("ecma" . "application/ecmascript")
("emma" . "application/emma+xml")
("epub" . "application/epub+zip")
("exi" . "application/exi")
("pfr" . "application/font-tdpfr")
("gml" . "application/gml+xml")
("gpx" . "application/gpx+xml")
("gxf" . "application/gxf")
("stk" . "application/hyperstudio")
("ink" . "application/inkml+xml")
("ipfix" . "application/ipfix")
("jar" . "application/java-archive")
("ser" . "application/java-serialized-object")
("class" . "application/java-vm")
("js" . "application/javascript")
("json" . "application/json")
("jsonml" . "application/jsonml+json")
("lostxml" . "application/lost+xml")
("hqx" . "application/mac-binhex40")
("cpt" . "application/mac-compactpro")
("mads" . "application/mads+xml")
("mrc" . "application/marc")
("mrcx" . "application/marcxml+xml")
("ma" . "application/mathematica")
("mathml" . "application/mathml+xml")
("mbox" . "application/mbox")
("mscml" . "application/mediaservercontrol+xml")
("metalink" . "application/metalink+xml")
("meta4" . "application/metalink4+xml")
("mets" . "application/mets+xml")
("mods" . "application/mods+xml")
("m21" . "application/mp21")
("mp4s" . "application/mp4")
("doc" . "application/msword")
("mxf" . "application/mxf")
("bin" . "application/octet-stream")
("oda" . "application/oda")
("opf" . "application/oebps-package+xml")
("ogx" . "application/ogg")
("omdoc" . "application/omdoc+xml")
("onetoc" . "application/onenote")
("oxps" . "application/oxps")
("xer" . "application/patch-ops-error+xml")
("pdf" . "application/pdf")
("pgp" . "application/pgp-encrypted")
("asc" . "application/pgp-signature")
("prf" . "application/pics-rules")
("p10" . "application/pkcs10")
("p7m" . "application/pkcs7-mime")
("p7s" . "application/pkcs7-signature")
("p8" . "application/pkcs8")
("ac" . "application/pkix-attr-cert")
("cer" . "application/pkix-cert")
("crl" . "application/pkix-crl")
("pkipath" . "application/pkix-pkipath")
("pki" . "application/pkixcmp")
("pls" . "application/pls+xml")
("ai" . "application/postscript")
("cww" . "application/prs.cww")
("pskcxml" . "application/pskc+xml")
("rdf" . "application/rdf+xml")
("rif" . "application/reginfo+xml")
("rnc" . "application/relax-ng-compact-syntax")
("rl" . "application/resource-lists+xml")
("rld" . "application/resource-lists-diff+xml")
("rs" . "application/rls-services+xml")
("gbr" . "application/rpki-ghostbusters")
("mft" . "application/rpki-manifest")
("roa" . "application/rpki-roa")
("rsd" . "application/rsd+xml")
("rss" . "application/rss+xml")
("rtf" . "application/rtf")
("sbml" . "application/sbml+xml")
("scq" . "application/scvp-cv-request")
("scs" . "application/scvp-cv-response")
("spq" . "application/scvp-vp-request")
("spp" . "application/scvp-vp-response")
("sdp" . "application/sdp")
("setpay" . "application/set-payment-initiation")
("setreg" . "application/set-registration-initiation")
("shf" . "application/shf+xml")
("smi" . "application/smil+xml")
("rq" . "application/sparql-query")
("srx" . "application/sparql-results+xml")
("gram" . "application/srgs")
("grxml" . "application/srgs+xml")
("sru" . "application/sru+xml")
("ssdl" . "application/ssdl+xml")
("ssml" . "application/ssml+xml")
("tei" . "application/tei+xml")
("tfi" . "application/thraud+xml")
("tsd" . "application/timestamped-data")
("plb" . "application/vnd.3gpp.pic-bw-large")
("psb" . "application/vnd.3gpp.pic-bw-small")
("pvb" . "application/vnd.3gpp.pic-bw-var")
("tcap" . "application/vnd.3gpp2.tcap")
("pwn" . "application/vnd.3m.post-it-notes")
("aso" . "application/vnd.accpac.simply.aso")
("imp" . "application/vnd.accpac.simply.imp")
("acu" . "application/vnd.acucobol")
("atc" . "application/vnd.acucorp")
("air" . "application/vnd.adobe.air-application-installer-package+zip")
("fcdt" . "application/vnd.adobe.formscentral.fcdt")
("fxp" . "application/vnd.adobe.fxp")
("xdp" . "application/vnd.adobe.xdp+xml")
("xfdf" . "application/vnd.adobe.xfdf")
("ahead" . "application/vnd.ahead.space")
("azf" . "application/vnd.airzip.filesecure.azf")
("azs" . "application/vnd.airzip.filesecure.azs")
("azw" . "application/vnd.amazon.ebook")
("acc" . "application/vnd.americandynamics.acc")
("ami" . "application/vnd.amiga.ami")
("apk" . "application/vnd.android.package-archive")
("cii" . "application/vnd.anser-web-certificate-issue-initiation")
("fti" . "application/vnd.anser-web-funds-transfer-initiation")
("atx" . "application/vnd.antix.game-component")
("mpkg" . "application/vnd.apple.installer+xml")
("m3u8" . "application/vnd.apple.mpegurl")
("swi" . "application/vnd.aristanetworks.swi")
("iota" . "application/vnd.astraea-software.iota")
("aep" . "application/vnd.audiograph")
("mpm" . "application/vnd.blueice.multipass")
("bmi" . "application/vnd.bmi")
("rep" . "application/vnd.businessobjects")
("cdxml" . "application/vnd.chemdraw+xml")
("mmd" . "application/vnd.chipnuts.karaoke-mmd")
("cdy" . "application/vnd.cinderella")
("cla" . "application/vnd.claymore")
("rp9" . "application/vnd.cloanto.rp9")
("c4g" . "application/vnd.clonk.c4group")
("c11amc" . "application/vnd.cluetrust.cartomobile-config")
("c11amz" . "application/vnd.cluetrust.cartomobile-config-pkg")
("csp" . "application/vnd.commonspace")
("cdbcmsg" . "application/vnd.contact.cmsg")
("cmc" . "application/vnd.cosmocaller")
("clkx" . "application/vnd.crick.clicker")
("clkk" . "application/vnd.crick.clicker.keyboard")
("clkp" . "application/vnd.crick.clicker.palette")
("clkt" . "application/vnd.crick.clicker.template")
("clkw" . "application/vnd.crick.clicker.wordbank")
("wbs" . "application/vnd.criticaltools.wbs+xml")
("pml" . "application/vnd.ctc-posml")
("ppd" . "application/vnd.cups-ppd")
("car" . "application/vnd.curl.car")
("pcurl" . "application/vnd.curl.pcurl")
("dart" . "application/vnd.dart")
("rdz" . "application/vnd.data-vision.rdz")
("uvf" . "application/vnd.dece.data")
("uvt" . "application/vnd.dece.ttml+xml")
("uvx" . "application/vnd.dece.unspecified")
("uvz" . "application/vnd.dece.zip")
("fe_launch" . "application/vnd.denovo.fcselayout-link")
("dna" . "application/vnd.dna")
("mlp" . "application/vnd.dolby.mlp")
("dpg" . "application/vnd.dpgraph")
("dfac" . "application/vnd.dreamfactory")
("kpxx" . "application/vnd.ds-keypoint")
("ait" . "application/vnd.dvb.ait")
("svc" . "application/vnd.dvb.service")
("geo" . "application/vnd.dynageo")
("mag" . "application/vnd.ecowin.chart")
("nml" . "application/vnd.enliven")
("esf" . "application/vnd.epson.esf")
("msf" . "application/vnd.epson.msf")
("qam" . "application/vnd.epson.quickanime")
("slt" . "application/vnd.epson.salt")
("ssf" . "application/vnd.epson.ssf")
("es3" . "application/vnd.eszigno3+xml")
("ez2" . "application/vnd.ezpix-album")
("ez3" . "application/vnd.ezpix-package")
("fdf" . "application/vnd.fdf")
("mseed" . "application/vnd.fdsn.mseed")
("seed" . "application/vnd.fdsn.seed")
("gph" . "application/vnd.flographit")
("ftc" . "application/vnd.fluxtime.clip")
("fm" . "application/vnd.framemaker")
("fnc" . "application/vnd.frogans.fnc")
("ltf" . "application/vnd.frogans.ltf")
("fsc" . "application/vnd.fsc.weblaunch")
("oas" . "application/vnd.fujitsu.oasys")
("oa2" . "application/vnd.fujitsu.oasys2")
("oa3" . "application/vnd.fujitsu.oasys3")
("fg5" . "application/vnd.fujitsu.oasysgp")
("bh2" . "application/vnd.fujitsu.oasysprs")
("ddd" . "application/vnd.fujixerox.ddd")
("xdw" . "application/vnd.fujixerox.docuworks")
("xbd" . "application/vnd.fujixerox.docuworks.binder")
("fzs" . "application/vnd.fuzzysheet")
("txd" . "application/vnd.genomatix.tuxedo")
("ggb" . "application/vnd.geogebra.file")
("ggt" . "application/vnd.geogebra.tool")
("gex" . "application/vnd.geometry-explorer")
("gxt" . "application/vnd.geonext")
("g2w" . "application/vnd.geoplan")
("g3w" . "application/vnd.geospace")
("gmx" . "application/vnd.gmx")
("kml" . "application/vnd.google-earth.kml+xml")
("kmz" . "application/vnd.google-earth.kmz")
("gqf" . "application/vnd.grafeq")
("gac" . "application/vnd.groove-account")
("ghf" . "application/vnd.groove-help")
("gim" . "application/vnd.groove-identity-message")
("grv" . "application/vnd.groove-injector")
("gtm" . "application/vnd.groove-tool-message")
("tpl" . "application/vnd.groove-tool-template")
("vcg" . "application/vnd.groove-vcard")
("hal" . "application/vnd.hal+xml")
("zmm" . "application/vnd.handheld-entertainment+xml")
("hbci" . "application/vnd.hbci")
("les" . "application/vnd.hhe.lesson-player")
("hpgl" . "application/vnd.hp-hpgl")
("hpid" . "application/vnd.hp-hpid")
("hps" . "application/vnd.hp-hps")
("jlt" . "application/vnd.hp-jlyt")
("pcl" . "application/vnd.hp-pcl")
("pclxl" . "application/vnd.hp-pclxl")
("sfd-hdstx" . "application/vnd.hydrostatix.sof-data")
("mpy" . "application/vnd.ibm.minipay")
("afp" . "application/vnd.ibm.modcap")
("irm" . "application/vnd.ibm.rights-management")
("sc" . "application/vnd.ibm.secure-container")
("icc" . "application/vnd.iccprofile")
("igl" . "application/vnd.igloader")
("ivp" . "application/vnd.immervision-ivp")
("ivu" . "application/vnd.immervision-ivu")
("igm" . "application/vnd.insors.igm")
("xpw" . "application/vnd.intercon.formnet")
("i2g" . "application/vnd.intergeo")
("qbo" . "application/vnd.intu.qbo")
("qfx" . "application/vnd.intu.qfx")
("rcprofile" . "application/vnd.ipunplugged.rcprofile")
("irp" . "application/vnd.irepository.package+xml")
("xpr" . "application/vnd.is-xpr")
("fcs" . "application/vnd.isac.fcs")
("jam" . "application/vnd.jam")
("rms" . "application/vnd.jcp.javame.midlet-rms")
("jisp" . "application/vnd.jisp")
("joda" . "application/vnd.joost.joda-archive")
("ktz" . "application/vnd.kahootz")
("karbon" . "application/vnd.kde.karbon")
("chrt" . "application/vnd.kde.kchart")
("kfo" . "application/vnd.kde.kformula")
("flw" . "application/vnd.kde.kivio")
("kon" . "application/vnd.kde.kontour")
("kpr" . "application/vnd.kde.kpresenter")
("ksp" . "application/vnd.kde.kspread")
("kwd" . "application/vnd.kde.kword")
("htke" . "application/vnd.kenameaapp")
("kia" . "application/vnd.kidspiration")
("kne" . "application/vnd.kinar")
("skp" . "application/vnd.koan")
("sse" . "application/vnd.kodak-descriptor")
("lasxml" . "application/vnd.las.las+xml")
("lbd" . "application/vnd.llamagraphics.life-balance.desktop")
("lbe" . "application/vnd.llamagraphics.life-balance.exchange+xml")
("123" . "application/vnd.lotus-1-2-3")
("apr" . "application/vnd.lotus-approach")
("pre" . "application/vnd.lotus-freelance")
("nsf" . "application/vnd.lotus-notes")
("org" . "application/vnd.lotus-organizer")
("scm" . "application/vnd.lotus-screencam")
("lwp" . "application/vnd.lotus-wordpro")
("portpkg" . "application/vnd.macports.portpkg")
("mcd" . "application/vnd.mcd")
("mc1" . "application/vnd.medcalcdata")
("cdkey" . "application/vnd.mediastation.cdkey")
("mwf" . "application/vnd.mfer")
("mfm" . "application/vnd.mfmp")
("flo" . "application/vnd.micrografx.flo")
("igx" . "application/vnd.micrografx.igx")
("mif" . "application/vnd.mif")
("daf" . "application/vnd.mobius.daf")
("dis" . "application/vnd.mobius.dis")
("mbk" . "application/vnd.mobius.mbk")
("mqy" . "application/vnd.mobius.mqy")
("msl" . "application/vnd.mobius.msl")
("plc" . "application/vnd.mobius.plc")
("txf" . "application/vnd.mobius.txf")
("mpn" . "application/vnd.mophun.application")
("mpc" . "application/vnd.mophun.certificate")
("xul" . "application/vnd.mozilla.xul+xml")
("cil" . "application/vnd.ms-artgalry")
("cab" . "application/vnd.ms-cab-compressed")
("xls" . "application/vnd.ms-excel")
("xlam" . "application/vnd.ms-excel.addin.macroenabled.12")
("xlsb" . "application/vnd.ms-excel.sheet.binary.macroenabled.12")
("xlsm" . "application/vnd.ms-excel.sheet.macroenabled.12")
("xltm" . "application/vnd.ms-excel.template.macroenabled.12")
("eot" . "application/vnd.ms-fontobject")
("chm" . "application/vnd.ms-htmlhelp")
("ims" . "application/vnd.ms-ims")
("lrm" . "application/vnd.ms-lrm")
("thmx" . "application/vnd.ms-officetheme")
("cat" . "application/vnd.ms-pki.seccat")
("stl" . "application/vnd.ms-pki.stl")
("ppt" . "application/vnd.ms-powerpoint")
("ppam" . "application/vnd.ms-powerpoint.addin.macroenabled.12")
("pptm" . "application/vnd.ms-powerpoint.presentation.macroenabled.12")
("sldm" . "application/vnd.ms-powerpoint.slide.macroenabled.12")
("ppsm" . "application/vnd.ms-powerpoint.slideshow.macroenabled.12")
("potm" . "application/vnd.ms-powerpoint.template.macroenabled.12")
("mpp" . "application/vnd.ms-project")
("docm" . "application/vnd.ms-word.document.macroenabled.12")
("dotm" . "application/vnd.ms-word.template.macroenabled.12")
("wps" . "application/vnd.ms-works")
("wpl" . "application/vnd.ms-wpl")
("xps" . "application/vnd.ms-xpsdocument")
("mseq" . "application/vnd.mseq")
("mus" . "application/vnd.musician")
("msty" . "application/vnd.muvee.style")
("taglet" . "application/vnd.mynfc")
("nlu" . "application/vnd.neurolanguage.nlu")
("ntf" . "application/vnd.nitf")
("nnd" . "application/vnd.noblenet-directory")
("nns" . "application/vnd.noblenet-sealer")
("nnw" . "application/vnd.noblenet-web")
("ngdat" . "application/vnd.nokia.n-gage.data")
("n-gage" . "application/vnd.nokia.n-gage.symbian.install")
("rpst" . "application/vnd.nokia.radio-preset")
("rpss" . "application/vnd.nokia.radio-presets")
("edm" . "application/vnd.novadigm.edm")
("edx" . "application/vnd.novadigm.edx")
("ext" . "application/vnd.novadigm.ext")
("odc" . "application/vnd.oasis.opendocument.chart")
("otc" . "application/vnd.oasis.opendocument.chart-template")
("odb" . "application/vnd.oasis.opendocument.database")
("odf" . "application/vnd.oasis.opendocument.formula")
("odft" . "application/vnd.oasis.opendocument.formula-template")
("odg" . "application/vnd.oasis.opendocument.graphics")
("otg" . "application/vnd.oasis.opendocument.graphics-template")
("odi" . "application/vnd.oasis.opendocument.image")
("oti" . "application/vnd.oasis.opendocument.image-template")
("odp" . "application/vnd.oasis.opendocument.presentation")
("otp" . "application/vnd.oasis.opendocument.presentation-template")
("ods" . "application/vnd.oasis.opendocument.spreadsheet")
("ots" . "application/vnd.oasis.opendocument.spreadsheet-template")
("odt" . "application/vnd.oasis.opendocument.text")
("odm" . "application/vnd.oasis.opendocument.text-master")
("ott" . "application/vnd.oasis.opendocument.text-template")
("oth" . "application/vnd.oasis.opendocument.text-web")
("xo" . "application/vnd.olpc-sugar")
("dd2" . "application/vnd.oma.dd2+xml")
("oxt" . "application/vnd.openofficeorg.extension")
("pptx" . "application/vnd.openxmlformats-officedocument.presentationml.presentation")
("sldx" . "application/vnd.openxmlformats-officedocument.presentationml.slide")
("ppsx" . "application/vnd.openxmlformats-officedocument.presentationml.slideshow")
("potx" . "application/vnd.openxmlformats-officedocument.presentationml.template")
("xlsx" . "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet")
("xltx" . "application/vnd.openxmlformats-officedocument.spreadsheetml.template")
("docx" . "application/vnd.openxmlformats-officedocument.wordprocessingml.document")
("dotx" . "application/vnd.openxmlformats-officedocument.wordprocessingml.template")
("mgp" . "application/vnd.osgeo.mapguide.package")
("dp" . "application/vnd.osgi.dp")
("esa" . "application/vnd.osgi.subsystem")
("pdb" . "application/vnd.palm")
("paw" . "application/vnd.pawaafile")
("str" . "application/vnd.pg.format")
("ei6" . "application/vnd.pg.osasli")
("efif" . "application/vnd.picsel")
("wg" . "application/vnd.pmi.widget")
("plf" . "application/vnd.pocketlearn")
("pbd" . "application/vnd.powerbuilder6")
("box" . "application/vnd.previewsystems.box")
("mgz" . "application/vnd.proteus.magazine")
("qps" . "application/vnd.publishare-delta-tree")
("ptid" . "application/vnd.pvi.ptid1")
("qxd" . "application/vnd.quark.quarkxpress")
("bed" . "application/vnd.realvnc.bed")
("mxl" . "application/vnd.recordare.musicxml")
("musicxml" . "application/vnd.recordare.musicxml+xml")
("cryptonote" . "application/vnd.rig.cryptonote")
("cod" . "application/vnd.rim.cod")
("rm" . "application/vnd.rn-realmedia")
("rmvb" . "application/vnd.rn-realmedia-vbr")
("link66" . "application/vnd.route66.link66+xml")
("st" . "application/vnd.sailingtracker.track")
("see" . "application/vnd.seemail")
("sema" . "application/vnd.sema")
("semd" . "application/vnd.semd")
("semf" . "application/vnd.semf")
("ifm" . "application/vnd.shana.informed.formdata")
("itp" . "application/vnd.shana.informed.formtemplate")
("iif" . "application/vnd.shana.informed.interchange")
("ipk" . "application/vnd.shana.informed.package")
("twd" . "application/vnd.simtech-mindmapper")
("mmf" . "application/vnd.smaf")
("teacher" . "application/vnd.smart.teacher")
("sdkm" . "application/vnd.solent.sdkm+xml")
("dxp" . "application/vnd.spotfire.dxp")
("sfs" . "application/vnd.spotfire.sfs")
("sdc" . "application/vnd.stardivision.calc")
("sda" . "application/vnd.stardivision.draw")
("sdd" . "application/vnd.stardivision.impress")
("smf" . "application/vnd.stardivision.math")
("sdw" . "application/vnd.stardivision.writer")
("sgl" . "application/vnd.stardivision.writer-global")
("smzip" . "application/vnd.stepmania.package")
("sm" . "application/vnd.stepmania.stepchart")
("sxc" . "application/vnd.sun.xml.calc")
("stc" . "application/vnd.sun.xml.calc.template")
("sxd" . "application/vnd.sun.xml.draw")
("std" . "application/vnd.sun.xml.draw.template")
("sxi" . "application/vnd.sun.xml.impress")
("sti" . "application/vnd.sun.xml.impress.template")
("sxm" . "application/vnd.sun.xml.math")
("sxw" . "application/vnd.sun.xml.writer")
("sxg" . "application/vnd.sun.xml.writer.global")
("stw" . "application/vnd.sun.xml.writer.template")
("sus" . "application/vnd.sus-calendar")
("svd" . "application/vnd.svd")
("sis" . "application/vnd.symbian.install")
("xsm" . "application/vnd.syncml+xml")
("bdm" . "application/vnd.syncml.dm+wbxml")
("xdm" . "application/vnd.syncml.dm+xml")
("tao" . "application/vnd.tao.intent-module-archive")
("pcap" . "application/vnd.tcpdump.pcap")
("tmo" . "application/vnd.tmobile-livetv")
("tpt" . "application/vnd.trid.tpt")
("mxs" . "application/vnd.triscape.mxs")
("tra" . "application/vnd.trueapp")
("ufd" . "application/vnd.ufdl")
("utz" . "application/vnd.uiq.theme")
("umj" . "application/vnd.umajin")
("unityweb" . "application/vnd.unity")
("uoml" . "application/vnd.uoml+xml")
("vcx" . "application/vnd.vcx")
("vsd" . "application/vnd.visio")
("vis" . "application/vnd.visionary")
("vsf" . "application/vnd.vsf")
("wbxml" . "application/vnd.wap.wbxml")
("wmlc" . "application/vnd.wap.wmlc")
("wmlsc" . "application/vnd.wap.wmlscriptc")
("wtb" . "application/vnd.webturbo")
("nbp" . "application/vnd.wolfram.player")
("wpd" . "application/vnd.wordperfect")
("wqd" . "application/vnd.wqd")
("stf" . "application/vnd.wt.stf")
("xar" . "application/vnd.xara")
("xfdl" . "application/vnd.xfdl")
("hvd" . "application/vnd.yamaha.hv-dic")
("hvs" . "application/vnd.yamaha.hv-script")
("hvp" . "application/vnd.yamaha.hv-voice")
("osf" . "application/vnd.yamaha.openscoreformat")
("osfpvg" . "application/vnd.yamaha.openscoreformat.osfpvg+xml")
("saf" . "application/vnd.yamaha.smaf-audio")
("spf" . "application/vnd.yamaha.smaf-phrase")
("cmp" . "application/vnd.yellowriver-custom-menu")
("zir" . "application/vnd.zul")
("zaz" . "application/vnd.zzazz.deck+xml")
("vxml" . "application/voicexml+xml")
("wgt" . "application/widget")
("hlp" . "application/winhlp")
("wsdl" . "application/wsdl+xml")
("wspolicy" . "application/wspolicy+xml")
("7z" . "application/x-7z-compressed")
("abw" . "application/x-abiword")
("ace" . "application/x-ace-compressed")
("dmg" . "application/x-apple-diskimage")
("aab" . "application/x-authorware-bin")
("aam" . "application/x-authorware-map")
("aas" . "application/x-authorware-seg")
("bcpio" . "application/x-bcpio")
("torrent" . "application/x-bittorrent")
("blb" . "application/x-blorb")
("bz" . "application/x-bzip")
("bz2" . "application/x-bzip2")
("cbr" . "application/x-cbr")
("vcd" . "application/x-cdlink")
("cfs" . "application/x-cfs-compressed")
("chat" . "application/x-chat")
("pgn" . "application/x-chess-pgn")
("nsc" . "application/x-conference")
("cpio" . "application/x-cpio")
("csh" . "application/x-csh")
("deb" . "application/x-debian-package")
("dgc" . "application/x-dgc-compressed")
("dir" . "application/x-director")
("wad" . "application/x-doom")
("ncx" . "application/x-dtbncx+xml")
("dtb" . "application/x-dtbook+xml")
("res" . "application/x-dtbresource+xml")
("dvi" . "application/x-dvi")
("evy" . "application/x-envoy")
("eva" . "application/x-eva")
("bdf" . "application/x-font-bdf")
("gsf" . "application/x-font-ghostscript")
("psf" . "application/x-font-linux-psf")
("otf" . "application/x-font-otf")
("pcf" . "application/x-font-pcf")
("snf" . "application/x-font-snf")
("ttf" . "application/x-font-ttf")
("pfa" . "application/x-font-type1")
("woff" . "application/x-font-woff")
("arc" . "application/x-freearc")
("spl" . "application/x-futuresplash")
("gca" . "application/x-gca-compressed")
("ulx" . "application/x-glulx")
("gnumeric" . "application/x-gnumeric")
("gramps" . "application/x-gramps-xml")
("gtar" . "application/x-gtar")
("hdf" . "application/x-hdf")
("install" . "application/x-install-instructions")
("iso" . "application/x-iso9660-image")
("jnlp" . "application/x-java-jnlp-file")
("latex" . "application/x-latex")
("lzh" . "application/x-lzh-compressed")
("mie" . "application/x-mie")
("prc" . "application/x-mobipocket-ebook")
("m3u8" . "application/x-mpegurl")
("application" . "application/x-ms-application")
("lnk" . "application/x-ms-shortcut")
("wmd" . "application/x-ms-wmd")
("wmz" . "application/x-ms-wmz")
("xbap" . "application/x-ms-xbap")
("mdb" . "application/x-msaccess")
("obd" . "application/x-msbinder")
("crd" . "application/x-mscardfile")
("clp" . "application/x-msclip")
("exe" . "application/x-msdownload")
("mvb" . "application/x-msmediaview")
("wmf" . "application/x-msmetafile")
("mny" . "application/x-msmoney")
("pub" . "application/x-mspublisher")
("scd" . "application/x-msschedule")
("trm" . "application/x-msterminal")
("wri" . "application/x-mswrite")
("nc" . "application/x-netcdf")
("nzb" . "application/x-nzb")
("p12" . "application/x-pkcs12")
("p7b" . "application/x-pkcs7-certificates")
("p7r" . "application/x-pkcs7-certreqresp")
("rar" . "application/x-rar-compressed")
("ris" . "application/x-research-info-systems")
("sh" . "application/x-sh")
("shar" . "application/x-shar")
("swf" . "application/x-shockwave-flash")
("xap" . "application/x-silverlight-app")
("sql" . "application/x-sql")
("sit" . "application/x-stuffit")
("sitx" . "application/x-stuffitx")
("srt" . "application/x-subrip")
("sv4cpio" . "application/x-sv4cpio")
("sv4crc" . "application/x-sv4crc")
("t3" . "application/x-t3vm-image")
("gam" . "application/x-tads")
("tar" . "application/x-tar")
("tcl" . "application/x-tcl")
("tex" . "application/x-tex")
("tfm" . "application/x-tex-tfm")
("texinfo" . "application/x-texinfo")
("obj" . "application/x-tgif")
("ustar" . "application/x-ustar")
("src" . "application/x-wais-source")
("der" . "application/x-x509-ca-cert")
("fig" . "application/x-xfig")
("xlf" . "application/x-xliff+xml")
("xpi" . "application/x-xpinstall")
("xz" . "application/x-xz")
("z1" . "application/x-zmachine")
("xaml" . "application/xaml+xml")
("xdf" . "application/xcap-diff+xml")
("xenc" . "application/xenc+xml")
("xhtml" . "application/xhtml+xml")
("xml" . "application/xml")
("dtd" . "application/xml-dtd")
("xop" . "application/xop+xml")
("xpl" . "application/xproc+xml")
("xslt" . "application/xslt+xml")
("xspf" . "application/xspf+xml")
("mxml" . "application/xv+xml")
("yang" . "application/yang")
("yin" . "application/yin+xml")
("zip" . "application/zip")
("adp" . "audio/adpcm")
("au" . "audio/basic")
("mid" . "audio/midi")
("mp4a" . "audio/mp4")
("m4a" . "audio/mp4a-latm")
("mpga" . "audio/mpeg")
("oga" . "audio/ogg")
("s3m" . "audio/s3m")
("sil" . "audio/silk")
("uva" . "audio/vnd.dece.audio")
("eol" . "audio/vnd.digital-winds")
("dra" . "audio/vnd.dra")
("dts" . "audio/vnd.dts")
("dtshd" . "audio/vnd.dts.hd")
("lvp" . "audio/vnd.lucent.voice")
("pya" . "audio/vnd.ms-playready.media.pya")
("ecelp4800" . "audio/vnd.nuera.ecelp4800")
("ecelp7470" . "audio/vnd.nuera.ecelp7470")
("ecelp9600" . "audio/vnd.nuera.ecelp9600")
("rip" . "audio/vnd.rip")
("weba" . "audio/webm")
("aac" . "audio/x-aac")
("aif" . "audio/x-aiff")
("caf" . "audio/x-caf")
("flac" . "audio/x-flac")
("mka" . "audio/x-matroska")
("m3u" . "audio/x-mpegurl")
("wax" . "audio/x-ms-wax")
("wma" . "audio/x-ms-wma")
("ram" . "audio/x-pn-realaudio")
("rmp" . "audio/x-pn-realaudio-plugin")
("wav" . "audio/x-wav")
("xm" . "audio/xm")
("cdx" . "chemical/x-cdx")
("cif" . "chemical/x-cif")
("cmdf" . "chemical/x-cmdf")
("cml" . "chemical/x-cml")
("csml" . "chemical/x-csml")
("xyz" . "chemical/x-xyz")
("bmp" . "image/bmp")
("cgm" . "image/cgm")
("g3" . "image/g3fax")
("gif" . "image/gif")
("ief" . "image/ief")
("jp2" . "image/jp2")
("jpeg" . "image/jpeg")
("ktx" . "image/ktx")
("pict" . "image/pict")
("png" . "image/png")
("btif" . "image/prs.btif")
("sgi" . "image/sgi")
("svg" . "image/svg+xml")
("tiff" . "image/tiff")
("psd" . "image/vnd.adobe.photoshop")
("uvi" . "image/vnd.dece.graphic")
("sub" . "image/vnd.dvb.subtitle")
("djvu" . "image/vnd.djvu")
("dwg" . "image/vnd.dwg")
("dxf" . "image/vnd.dxf")
("fbs" . "image/vnd.fastbidsheet")
("fpx" . "image/vnd.fpx")
("fst" . "image/vnd.fst")
("mmr" . "image/vnd.fujixerox.edmics-mmr")
("rlc" . "image/vnd.fujixerox.edmics-rlc")
("mdi" . "image/vnd.ms-modi")
("wdp" . "image/vnd.ms-photo")
("npx" . "image/vnd.net-fpx")
("wbmp" . "image/vnd.wap.wbmp")
("xif" . "image/vnd.xiff")
("webp" . "image/webp")
("3ds" . "image/x-3ds")
("ras" . "image/x-cmu-raster")
("cmx" . "image/x-cmx")
("fh" . "image/x-freehand")
("ico" . "image/x-icon")
("pntg" . "image/x-macpaint")
("sid" . "image/x-mrsid-image")
("pcx" . "image/x-pcx")
("pic" . "image/x-pict")
("pnm" . "image/x-portable-anymap")
("pbm" . "image/x-portable-bitmap")
("pgm" . "image/x-portable-graymap")
("ppm" . "image/x-portable-pixmap")
("qtif" . "image/x-quicktime")
("rgb" . "image/x-rgb")
("tga" . "image/x-tga")
("xbm" . "image/x-xbitmap")
("xpm" . "image/x-xpixmap")
("xwd" . "image/x-xwindowdump")
("eml" . "message/rfc822")
("igs" . "model/iges")
("msh" . "model/mesh")
("dae" . "model/vnd.collada+xml")
("dwf" . "model/vnd.dwf")
("gdl" . "model/vnd.gdl")
("gtw" . "model/vnd.gtw")
("mts" . "model/vnd.mts")
("vtu" . "model/vnd.vtu")
("wrl" . "model/vrml")
("x3db" . "model/x3d+binary")
("x3dv" . "model/x3d+vrml")
("x3d" . "model/x3d+xml")
("manifest" . "text/cache-manifest")
("appcache" . "text/cache-manifest")
("ics" . "text/calendar")
("css" . "text/css")
("csv" . "text/csv")
("html" . "text/html")
("n3" . "text/n3")
("txt" . "text/plain")
("dsc" . "text/prs.lines.tag")
("rtx" . "text/richtext")
("sgml" . "text/sgml")
("tsv" . "text/tab-separated-values")
("t" . "text/troff")
("ttl" . "text/turtle")
("uri" . "text/uri-list")
("vcard" . "text/vcard")
("curl" . "text/vnd.curl")
("dcurl" . "text/vnd.curl.dcurl")
("scurl" . "text/vnd.curl.scurl")
("mcurl" . "text/vnd.curl.mcurl")
("sub" . "text/vnd.dvb.subtitle")
("fly" . "text/vnd.fly")
("flx" . "text/vnd.fmi.flexstor")
("gv" . "text/vnd.graphviz")
("3dml" . "text/vnd.in3d.3dml")
("spot" . "text/vnd.in3d.spot")
("jad" . "text/vnd.sun.j2me.app-descriptor")
("wml" . "text/vnd.wap.wml")
("wmls" . "text/vnd.wap.wmlscript")
("s" . "text/x-asm")
("c" . "text/x-c")
("f" . "text/x-fortran")
("java" . "text/x-java-source")
("opml" . "text/x-opml")
("p" . "text/x-pascal")
("nfo" . "text/x-nfo")
("etx" . "text/x-setext")
("sfv" . "text/x-sfv")
("uu" . "text/x-uuencode")
("vcs" . "text/x-vcalendar")
("vcf" . "text/x-vcard")
("3gp" . "video/3gpp")
("3g2" . "video/3gpp2")
("h261" . "video/h261")
("h263" . "video/h263")
("h264" . "video/h264")
("jpgv" . "video/jpeg")
("jpm" . "video/jpm")
("mj2" . "video/mj2")
("ts" . "video/mp2t")
("mp4" . "video/mp4")
("mpeg" . "video/mpeg")
("ogv" . "video/ogg")
("qt" . "video/quicktime")
("uvh" . "video/vnd.dece.hd")
("uvm" . "video/vnd.dece.mobile")
("uvp" . "video/vnd.dece.pd")
("uvs" . "video/vnd.dece.sd")
("uvv" . "video/vnd.dece.video")
("dvb" . "video/vnd.dvb.file")
("fvt" . "video/vnd.fvt")
("mxu" . "video/vnd.mpegurl")
("pyv" . "video/vnd.ms-playready.media.pyv")
("uvu" . "video/vnd.uvvu.mp4")
("viv" . "video/vnd.vivo")
("dv" . "video/x-dv")
("webm" . "video/webm")
("f4v" . "video/x-f4v")
("fli" . "video/x-fli")
("flv" . "video/x-flv")
("m4v" . "video/x-m4v")
("mkv" . "video/x-matroska")
("mng" . "video/x-mng")
("asf" . "video/x-ms-asf")
("vob" . "video/x-ms-vob")
("wm" . "video/x-ms-wm")
("wmv" . "video/x-ms-wmv")
("wmx" . "video/x-ms-wmx")
("wvx" . "video/x-ms-wvx")
("avi" . "video/x-msvideo")
("movie" . "video/x-sgi-movie")
("smv" . "video/x-smv")
("ice" . "x-conference/x-cooltalk")))

(define (ext->mimetype ext)
  (let ((x (assoc ext ducttape_ext2mimetype)))
   (if x (cdr x) "text/plain")))








Added ducttape/sample_ducttape.scm version [d6ebb1f644].








1
2
3
4

+
+
+
+

(include "ducttape-lib.scm")
(import ducttape-lib)
(inote "hello world")
(exit 0)








Added ducttape/test_ducttape.scm version [f1892fd163].







































































































































































































































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
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
227
228
229
230
231
232
233
234
235
236
237
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
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

#!/usr/bin/env csi -script
(use test)
(include "ducttape-lib.scm")
(import ducttape-lib)
(import ansi-escape-sequences)
(use trace)
(set! systype (do-or-die (if (file-exists? "/bin/uname") "/bin/uname" "/usr/bin/uname")))
;(trace skim-cmdline-opts-withargs-by-regex)
;(trace keyword-skim)
;(trace re-match?)
(define (reset-ducttape)
  (unsetenv "DUCTTAPE_DEBUG_LEVEL")
  (ducttape-debug-level #f)

  (unsetenv "DUCTTAPE_DEBUG_PATTERN")
  (ducttape-debug-regex-filter ".")

  (unsetenv "DUCTTAPE_LOG_FILE")
  (ducttape-log-file #f)

  (unsetenv "DUCTTAPE_SILENT_MODE")
  (ducttape-silent-mode #f)

  (unsetenv "DUCTTAPE_QUIET_MODE")
  (ducttape-quiet-mode #f)

  (unsetenv "DUCTTAPE_COLOR_MODE")
  (ducttape-color-mode #f)
)

(define (reset-ducttape-with-cmdline-list cmdline-list)
  (reset-ducttape)

  (command-line-arguments cmdline-list)
  (ducttape-process-command-line)
)


(define (direct-iputs-test)
  (ducttape-color-mode #f)
  (ierr "I'm an error")
  (iwarn "I'm a warning")
  (inote "I'm a note")

  (ducttape-debug-level 1)
  (idbg "I'm a debug statement")
  (ducttape-debug-level #f)
  (idbg "I'm a hidden debug statement")

  (ducttape-silent-mode #t)
  (iwarn "I shouldn't show up")
  (inote "I shouldn't show up either")
  (ierr "I should show up 1")
  (ducttape-silent-mode #f)

  (ducttape-quiet-mode #t)
  (iwarn "I should show up 2")
  (inote "I shouldn't show up though")
  (ierr "I should show up 3")
  (ducttape-quiet-mode #f)

  (ducttape-debug-level 1)
  (idbg "foo")
  (iputs "dbg" "debug message")
  (iputs "e" "error message")
  (iputs "w" "warning message")
  (iputs "n" "note message")

  (ducttape-color-mode #t)
  (ierr "I'm an error COLOR")
  (iwarn "I'm a warning COLOR")
  (inote "I'm a note COLOR")
  (idbg "I'm a debug COLOR")


  )

(define (test-argprocessor-funcs)
  
  (test-group
   "Command line processor utility functions"

   (set! testargs1 '( "-d" "-d" "-d3" "-ddd" "-foo" "fooarg" "-foo" "fooarg2" "-lastArgIsDecoy" "-foo"))
   (command-line-arguments testargs1)
   (set! expected_result '("-d" "-d" "-d3" "-ddd"))
   (set! expected_sideeffect '("-foo" "fooarg" "-foo" "fooarg2" "-lastArgIsDecoy" "-foo"))

   (test "skim-cmdline-opts-noarg-by-regex result" expected_result (skim-cmdline-opts-noarg-by-regex "-d(d+|\\d+)?"))
   (test "skim-cmdline-opts-noarg-by-regex sideeffect" expected_sideeffect (command-line-arguments))


  
   (command-line-arguments testargs1)
   (set! expected_result '("fooarg" "fooarg2" ))
   (set! expected_sideeffect '( "-d" "-d" "-d3" "-ddd" "-lastArgIsDecoy" "-foo"))
   (test
    "skim-cmdline-opts-withargs-by-regex result"
    expected_result
    (skim-cmdline-opts-withargs-by-regex "--?foo"))
   
   (test
    "skim-cmdline-opts-withargs-by-regex sideeffect"
    expected_sideeffect
    (command-line-arguments))

   ))

(define (test-misc)
  (test-group
   "misc"
   (let ((tmpfile (mktemp)))
     (test-assert "mktemp: temp file created" (file-exists? tmpfile))
     (if (file-exists? tmpfile)
         (delete-file tmpfile))

     )))



(define (test-systemstuff)
  (test-group
   "system commands"

   (let-values (((ec o e) (isys (find-exe "true"))))
     (test-assert "isys: /bin/true should have exit code 0" (equal? ec 0)))
   (let-values (((ec o e) (isys (find-exe "false"))))
     (test-assert "isys: /bin/false should have exit code 1" (equal? ec 1)))

   (let-values (((ec o e) (isys "/bin/echo" "foo" "bar" "baz")))
     (test-assert "isys: /bin/echo should have exit code 0" (equal? ec 0))
     (test-assert "isys: /bin/echo should have stdout 'foo bar baz'" (equal? o "foo bar baz")))
   
   (let-values (((ec o e) (isys "/bin/ls /zzzzz")))
     (let ((expected-code
            (if (equal? systype "Darwin") 1 2))
           (expected-err
            (if (equal? systype "Darwin")
                "ls: /zzzzz: No such file or directory"
                "/bin/ls: cannot access /zzzzz: No such file or directory"))

           )
       (test "isys: /bin/ls /zzzzz should have exit code 2" expected-code ec)
       (test "isys: /bin/ls /zzzzz should have empty stdout" "" o)
       (test
        "isys: /bin/ls /zzzzz should have stderr"
        expected-err
        e))
     )

   (let-values (((ec o e) (isys "/bin/ls /etc/passwd")))
     (test "isys: /bin/ls /etc/passwd should have exit code 0" 0 ec)
     (test "isys: /bin/ls /etc/passwd should have stdout" "/etc/passwd" o)
     (test
      "isys: /bin/ls /etc/passwd should have empty stderr"
      ""
      e))

      (let ((res (do-or-die "/bin/ls /etc/passwd")))
        (test
         "do-or-die: ls /etc/passwd should work"
         "/etc/passwd" res ))

      (let ((res (do-or-die "/bin/ls /zzzzz" nodie: #t)))
        (test
         "do-or-die: ls /zzzzz should die"
         #f res ))

      ; test reading from process stdout line at a time
      (let* (
             (lineno (counter-maker))

             ; print each line with an index
             (eachline-fn (lambda (line)
                         (print "GOTLINE " (lineno) "> " line)))

             (res
              (do-or-die "/bin/ls -l /etc | head; true"
                         foreach-stdout: eachline-fn )))
        
        (test-assert "ls -l /etc should not be empty"
                     (not (equal? res ""))))
      ;; test writing to process stdout line at a time

      (let* ((tmpfile (mktemp))
             (cmd (conc "cat > " tmpfile)))
        (let-values (((c o e)
                      (isys cmd stdin-proc:
                       (lambda (myport)
                         (write-line "hello" myport)
                         (write-line "hello2" myport)
                         (close-output-port myport)))))
          (test "isys-sp: cat should exit 0" 0 c)
          (let ((mycmd (conc "cat " tmpfile)))
            (test "isys-sp: cat output should match input" "hello\nhello2" (do-or-die mycmd)))

          (delete-file tmpfile)
        ))

      (let* ((tmpfile (mktemp))
             (cmd (conc "cat > " tmpfile)))
        (do-or-die cmd stdin-proc:
                   (lambda (myport)
                     (write-line "hello" myport)
                     (write-line "hello2" myport)
                     (close-output-port myport))
                   cmd)
        (test "dod-sp: cat output should match input" "hello\nhello2" (do-or-die (conc "cat " tmpfile)))
        (delete-file tmpfile))



      

      (let*
          ((thefile (conc "/tmp/" (get-environment-variable "USER")  "9-lines"))
           (counter (counter-maker))
           (stdin-writer
            (lambda ()
              (if (< (counter) 10)
                  (number->string (counter 0))
                  #f)))
            (cmd (conc "cat > " thefile)))
        (let-values
            (((c o e)
              (isys cmd foreach-stdin-thunk: stdin-writer)))

          (test-assert "isys-fsl: cat should return 0" (equal? c 0))

          (test-assert
           "isys-fsl: cat should have written a file"
           (file-exists? thefile))
          
          (if
           (file-exists? thefile)
           (begin
             (test "isys-fsl: cat file should have right contents" "1\n2\n3\n4\n5\n6\n7\n8\n9" (do-or-die (conc "cat " thefile)))
             (delete-file thefile)))))
      
   ) ; end test-group
  ) ; end define

   
(define (test-argprocessor )
  (test-group
   "Command line processor parameter settings"

   (reset-ducttape-with-cmdline-list '())
   (test-assert "(nil) debug mode should be off" (not (ducttape-debug-level)))
   (test-assert "(nil): debug pattern should be '.'" (equal? "." (ducttape-debug-regex-filter)))
   (test-assert "(nil): colors should be off" (not (ducttape-color-mode)))
   (test-assert "(nil): silent mode should be off" (not (ducttape-silent-mode)))
   (test-assert "(nil): quiet mode should be off" (not (ducttape-quiet-mode)))
   (test-assert "(nil): logfile should be off" (not (ducttape-log-file)))

   (reset-ducttape-with-cmdline-list '("-d"))
   (test-assert "-d: debug mode should be on at level 1" (eq? 1 (ducttape-debug-level)))

   (reset-ducttape-with-cmdline-list '("-dd"))
   (test "-dd: debug level should be 2" 2 (ducttape-debug-level))

   (reset-ducttape-with-cmdline-list '("-ddd"))
   (test "-ddd: debug level should be 3" 3 (ducttape-debug-level))

   (reset-ducttape-with-cmdline-list '("-d2"))
   (test "-d2: debug level should be 2" 2 (ducttape-debug-level))

   (reset-ducttape-with-cmdline-list '("-d3"))
   (test "-d3: debug level should be 3" 3 (ducttape-debug-level))

   (reset-ducttape-with-cmdline-list '("-dp" "foo"))
   (test "-dp foo: debug pattern should be 'foo'" "foo" (ducttape-debug-regex-filter))

   (reset-ducttape-with-cmdline-list '("--debug-pattern" "foo"))
   (test "--debug-pattern foo: debug pattern should be 'foo'" "foo" (ducttape-debug-regex-filter))

   (reset-ducttape-with-cmdline-list '("-dp" "foo" "-dp" "bar"))
   (test "-dp foo -dp bar: debug pattern should be 'foo|bar'"  "foo|bar" (ducttape-debug-regex-filter))

   (reset-ducttape-with-cmdline-list '("--quiet"))
   (test-assert "-quiet: quiet mode should be active" (ducttape-quiet-mode))

   (reset-ducttape-with-cmdline-list '("--silent"))
   (test-assert "-silent: silent mode should be active" (ducttape-silent-mode))

   (reset-ducttape-with-cmdline-list '("--color"))
   (test-assert "-color: color mode should be active" (ducttape-color-mode))

   (reset-ducttape-with-cmdline-list '("--log" "foo"))
   (test "--log foo: logfile should be 'foo'" "foo" (ducttape-log-file))

))

(define (test-wwdate)
  (test-group
   "wwdate conversion tests"
   (let ((test-table
          '(("16ww01.5" . "2016-01-01")
            ("16ww18.5" . "2016-04-29")
            ("1999ww33.5" . "1999-08-13")
            ("16ww18.4" . "2016-04-28")
            ("16ww18.3" . "2016-04-27")
            ("13ww01.0" . "2012-12-30")
            ("13ww52.6" . "2013-12-28")
            ("16ww53.3" . "2016-12-28"))))
     (for-each
      (lambda (test-pair)
        (let ((wwdate (car test-pair))
              (isodate (cdr test-pair)))
          (test
           (conc "(isodate->wwdate "isodate ") => "wwdate)
           wwdate
           (isodate->wwdate isodate))
          
          (test
           (conc "(wwdate->isodate "wwdate ")   => "isodate)
           isodate
           (wwdate->isodate wwdate))))
      test-table))))

(define (main)
  ;; (test <description; #f uses func prototype> <expected result> <thunk>)
  
;  (test-group "silly settext group"
;              (test #f "\x1b[1mfoo\x1b[0m" (set-text (list 'bold) "foo"))
;              (test "settext bold" "\x1b[1mfoo\x1b[0m" (set-text (list 'bold) "foo"))
;              )

  ; visually inspect this
  (direct-iputs-test)

  ; following use unit test test-egg
  (reset-ducttape)
  (test-argprocessor-funcs)
  (reset-ducttape)
  (test-argprocessor)
  (test-systemstuff)
  (test-misc)
  (test-wwdate)
  ) ; end main()

(main)
(sendmail "brandon.j.barclay@intel.com" "6hello subject"  "test body" )

;(let* ((image-file "/nfs/site/home/bjbarcla/megatest-logo.png")
;       (cid "mtlogo")
;       (image-alist (list (cons image-file cid)))
;       (body  (conc "Hello world<br /><img cid:"cid" alt=\"test image\"><br>bye!")))

;  (sendmail "brandon.j.barclay@intel.com" "7hello subject"  body use_html: #t images-with-content-id-alist: image-alist)
;  (print "sent image mail"))
;(sendmail "bjbarcla" "2hello subject html"  "test body<h1>hello</h1><i>italics</i>" use_html: #t)
;(sendmail "bb" "4hello attach subject html"  "<h2>hmm</h2>" use_html: #t attach-files-list: '( "/Users/bb/Downloads/wdmycloud-manual-4779-705103.pdf" ) )

;(launch-repl)
(test-exit)








Added ducttape/test_example.scm version [74b706bd1d].







1
2
3

+
+
+

(use ducttape-lib)

(inote "Hello world")








Added ducttape/useargs-example.scm version [c73af521bf].























1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

(use ducttape-lib)

(let (
      (customers (skim-cmdline-opts-withargs-by-regex "--cust(omer)?"))
      (magicmode (skim-cmdline-opts-noarg-by-regex "--magic"))
      )
  (print "your customers are " customers)
  (if (null? magicmode)
      (print "no unicorns for you")
      (print "magic!")
  )
  )

(idbg "hello")
(idbg "hello2" 2)
(idbg "hello2" 3)
(inote "note")
(iwarn "warn")
(ierr "err")








Added ducttape/workweekdate.scm version [075bec1c4d].





































































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

(use srfi-19)
(use test)
;;(use format)
(use regex)
;(declare (unit wwdate))
;; utility procedures to convert among
;; different ways to express date (wwdate, seconds since epoch, isodate)
;;
;; samples:
;; isodate   -> "2016-01-01"
;; wwdate -> "16ww01.5"
;; seconds   -> 1451631600

;; procedures provided:
;; ====================
;; seconds->isodate
;; seconds->wwdate
;;
;; isodate->seconds
;; isodate->wwdate
;;
;; wwdate->seconds
;; wwdate->isodate

;; srfi-19 used extensively; this doc is better tha the eggref:
;; http://srfi.schemers.org/srfi-19/srfi-19.html

;; Author: brandon.j.barclay@intel.com 16ww18.6

(define (date->seconds date)
  (inexact->exact
   (string->number
    (date->string date "~s"))))

(define (seconds->isodate seconds)
  (let* ((date (seconds->date seconds))
         (result (date->string date "~Y-~m-~d")))
    result))

(define (isodate->seconds isodate)
  "Takes a string input of the form 'YY-MM-DD' or 'YYYY-MM-DD' and returns epoch time; for YY, assume after Y2K"
  (let* ((numlist (map string->number (string-split isodate "-")))
        (raw-year (car numlist))
        (year (if (< raw-year 100) (+ raw-year 2000) raw-year))
        (month (list-ref numlist 1))
        (day (list-ref numlist 2))
        (date (make-date 0 0 0 0 day month year))
        (seconds (date->seconds date)))

    seconds))

;; adapted from perl Intel::WorkWeek perl module
;; workweek year consists of numbered weeks starting from week 1
;;   days of week are numbered starting from 0 on sunday
;;   weeks begin on sunday- day number 0 and end saturday- day 6
;;   week 1 is defined as the week containing jan 1 of the year
;;   workweek year does not match calendar year in workweek 1
;;     since workweek 1 contains jan1 and workweek begins sunday,
;;     days prior to jan1 in workweek 1 belong to the next workweek year
(define (seconds->wwdate-values seconds)
  (define (date-difference->seconds d1 d2)
    (- (date->seconds d1) (date->seconds d2)))

  (let* ((thisdate (seconds->date seconds))
         (thisdow (string->number (date->string thisdate "~w")))

         (year (date-year thisdate))
         ;; intel workweek 1 begins on sunday of week containing jan1
         (jan1 (make-date 0 0 0 0 1 1 year))
         (jan1dow (date-week-day jan1))
         (ww01 (date-subtract-duration jan1 (seconds->time (* 60 60 24 jan1dow))))

         (ww01_delta_seconds (date-difference->seconds thisdate ww01))
         (wwnum_initial (inexact->exact (add1 (floor (/ ww01_delta_seconds 24 3600 7) ))))
         
         ;; we could be in ww1 of next year
         (this-saturday (seconds->date
                         (+ seconds
                            (* 60 60 24 (- 6 thisdow)))))
         (this-week-ends-next-year?
          (> (date-year this-saturday) year))
         (intelyear
          (if this-week-ends-next-year?
              (add1 year)
              year))
         (intelweek
          (if this-week-ends-next-year?
              1
              wwnum_initial)))
   (values intelyear intelweek thisdow)))

(define (string-leftpad in width pad-char)
  (let* ((unpadded-str (->string in))
         (padlen_temp (- width (string-length unpadded-str)))
         (padlen (if (< padlen_temp 0) 0 padlen_temp))
         (padding (make-string padlen pad-char)))
    (conc padding unpadded-str)))

(define (string-rightpad in width pad-char)
  (let* ((unpadded-str (->string in))
         (padlen_temp (- width (string-length unpadded-str)))
         (padlen (if (< padlen_temp 0) 0 padlen_temp))
         (padding (make-string padlen pad-char)))
    (conc unpadded-str padding)))

(define (zeropad num width)
  (string-leftpad num width #\0))

(define (seconds->wwdate seconds)

  (let-values (((intelyear intelweek day-of-week-num)
                (seconds->wwdate-values seconds)))
    (let ((intelyear-str
           (zeropad
            (->string
             (if (> intelyear 1999)
                 (- intelyear 2000) intelyear))
            2))
          (intelweek-str
           (zeropad (->string intelweek) 2))
          (dow-str (->string day-of-week-num)))
      (conc intelyear-str "ww" intelweek-str "." dow-str))))

(define (isodate->wwdate isodate)
  (seconds->wwdate
   (isodate->seconds isodate)))

(define (wwdate->seconds wwdate)
  (let ((match (string-match "^(\\d+)ww(\\d+).(\\d)$" wwdate)))
    (if
     (not match)
     #f
     (let* (
            (intelyear-raw (string->number (list-ref match 1)))
            (intelyear (if (< intelyear-raw 100)
                           (+ intelyear-raw 2000)
                           intelyear-raw))
            (intelww (string->number (list-ref match 2)))
            (dayofweek (string->number (list-ref match 3)))

            (day-of-seconds (* 60 60 24 ))
            (week-of-seconds (* day-of-seconds 7))
            

            ;; get seconds at ww1.0
            (new-years-date (make-date 0 0 0 0 1 1 intelyear))
            (new-years-seconds
             (date->seconds new-years-date))
            (new-years-dayofweek (date-week-day new-years-date))
            (ww1.0_seconds (- new-years-seconds
                              (* day-of-seconds
                                 new-years-dayofweek)))
            (workweek-adjustment (* week-of-seconds (sub1 intelww)))
            (weekday-adjustment (* dayofweek day-of-seconds))

            (result (+ ww1.0_seconds workweek-adjustment weekday-adjustment)))
       result))))

(define (wwdate->isodate wwdate)
  (seconds->isodate (wwdate->seconds wwdate)))

(define (current-wwdate)
  (seconds->wwdate (current-seconds)))

(define (current-isodate)
  (seconds->isodate (current-seconds)))

(define (wwdate-tests)
  (test-group
   "date conversion tests"
   (let ((test-table
          '(("16ww01.5" . "2016-01-01")
            ("16ww18.5" . "2016-04-29")
            ("1999ww33.5" . "1999-08-13")
            ("16ww18.4" . "2016-04-28")
            ("16ww18.3" . "2016-04-27")
            ("13ww01.0" . "2012-12-30")
            ("13ww52.6" . "2013-12-28")
            ("16ww53.3" . "2016-12-28"))))
     (for-each
      (lambda (test-pair)
        (let ((wwdate (car test-pair))
              (isodate (cdr test-pair)))
          (test
           (conc "(isodate->wwdate "isodate ") => "wwdate)
           wwdate
           (isodate->wwdate isodate))
          
          (test
           (conc "(wwdate->isodate "wwdate ")   => "isodate)
           isodate
           (wwdate->isodate wwdate))))
      test-table))))








Modified http-transport.scm
from [19992c5895]
to [7a68d0e73d].




︙


38
39
40
41
42
43
44
45

46
47
48
49
50
51
52

38
39
40
41
42
43
44

45
46
47
48
49
50
51
52








-
+








(declare (uses portlogger))
(declare (uses rmt))

(include "common_records.scm")
(include "db_records.scm")
(include "js-path.scm")

(require-library stml)
(import stml2)
(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 megatest.scm
from [7e6fcbd15f]
to [cd4b9c8593].




︙


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

18
19
20
21
22
23
24












25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47


48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86








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












+
+
+







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








+
+
+
+
+
+
+
+
+
+
+
+









;; (include "common.scm")
;; (include "megatest-version.scm")

;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)

(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:)
     readline apropos json http-client directory-utils typed-records
     http-client srfi-18 extras format)

;; Added for csv stuff - will be removed
;;
(use sparse-vectors)

(require-library mutils)

;; (use zmq)

(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses runs))
(declare (uses launch))
(declare (uses server))
(declare (uses client))
(declare (uses tests))
(declare (uses genexample))
;; (declare (uses daemon))
(declare (uses db))
;; (declare (uses dcommon))
(declare (uses stml2))
(declare (uses pkts))
(declare (uses mutils))

(declare (uses tdb))
(declare (uses mt))
(declare (uses api))
(declare (uses tasks)) ;; only used for debugging.
(declare (uses env))
(declare (uses diff-report))
(declare (uses commonmod))
(declare (uses ftail))
(import ftail)
;; (declare (uses ftail))
;; (import ftail)

(import stml2 mutils commonmod)

;; invoke the imports
;; (declare (uses mtargs.import))
;; (declare (uses mtconfigf.import))
(declare (uses cookie.import))
(declare (uses stml2.import))
(declare (uses pkts.import))
(declare (uses commonmod.import))

(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")
(include "megatest-fossil-hash.scm")

(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:)
     readline apropos json http-client directory-utils typed-records
     http-client srfi-18 extras format)

;; Added for csv stuff - will be removed
;;
(use sparse-vectors)

(import mutils ducttape-lib stml2)

;; (use zmq)

(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

;; load the ~/.megatestrc file, put (use trace)(trace-call-sites #t)(trace function-you-want-to-trace) in this file
;;
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.megatestrc")))




︙


224
225
226
227
228
229
230
231

232
233
234
235
236

237
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

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
266
267
268
269


270
271
272
273
274
275
276
277
278








-
+




-
+

-
-
+
+
-
















-
-
+
+








  -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
                            cmd: keep-html, restore, save, save-remove, get (use -dest to set destination)
  -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
  -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>

  		
  -syscheck               : do some very basic checks; write access and space in tmp, home, runs, links and 
                            is $DISPLAY valid 


Diff report
  -diff-rep               : generate diff report (must include -src-target, -src-runname, -target, -runname
                                                  and either -diff-email or -diff-html)
  -src-target <target>
  -src-runname <target>
  -diff-email <emails>    : comma separated list of email addresses to send diff report
  -diff-html  <rep.html>  : path to html file to generate

Spreadsheet generation
  -extract-ods fname.ods  : extract an open document spreadsheet from the database
  -pathmod path           : insert path, i.e. path/runame/itempath/logfile.html
                            will clear the field if no rundir/testname/itempath/logfile
                            if it contains forward slashes the path will be converted
                            to windows style
Getting started
  -create-megatest-area       : create a skeleton megatest area. You will be prompted for paths
  -create-test testname       : create a skeleton megatest test. You will be prompted for info
  -create-megatest-area   : create a skeleton megatest area. You will be prompted for paths
  -create-test testname   : create a skeleton megatest test. You will be prompted for info

Examples

# Get test path, use '.' to get a single path or a specific path/file pattern
megatest -test-files 'logs/*.log' -target ubuntu/n%/no% -runname w49% -testpatt test_mt%

Called as " (string-intersperse (argv) " ") "




︙


297
298
299
300
301
302
303

304
305
306
307
308
309
310

310
311
312
313
314
315
316
317
318
319
320
321
322
323
324








+








			"-logpro"
			"-m"
			"-rerun"

			"-days"
			"-rename-run"
			"-to"
			"-dest"
			;; values and messages
			":category"
			":variable"
			":value"
			":expected"
			":tol"
			":units"




︙


434
435
436
437
438
439
440


441
442
443
444
445
446
447

448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463








+
+








			"-sync-to-megatest.db"
                        "-sync-brute-force"
			"-logging"
			"-v" ;; verbose 2, more than normal (normal is 1)
			"-q" ;; quiet 0, errors/warnings only

                        "-diff-rep"

			"-syscheck"
                        )
		 args:arg-hash
		 0))

;; Add args that use remargs here
;;
(if (and (not (null? remargs))




︙


1039
1040
1041
1042
1043
1044
1045
1046

1047








1048


1049
1050
1051


1052
1053
1054
1055



1056
1057
1058



1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073



1074
1075
1076
1077
1078
1079
1080

1055
1056
1057
1058
1059
1060
1061

1062
1063
1064
1065
1066
1067
1068
1069
1070
1071

1072
1073
1074
1075

1076
1077
1078



1079
1080
1081
1082


1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097



1098
1099
1100
1101
1102
1103
1104
1105
1106
1107








-
+

+
+
+
+
+
+
+
+
-
+
+


-
+
+

-
-
-
+
+
+

-
-
+
+
+












-
-
-
+
+
+









;;======================================================================
;; Remove old run(s)
;;======================================================================

;; since several actions can be specified on the command line the removal
;; is done first
(define (operate-on action #!key (mode #f)) ;; #f is "use default"
(define (operate-on action #!key (mode #f)(target-in #f)(runname-in #f)(keys-in #f)(keyvals-in #f)) ;; #f is "use default"
  (let* ((runrec (runs:runrec-make-record))
	 (target (or target-in   (common:args-get-target))) ;; eventually get rid of the call to common:args-get-target
	 (runname (or runname-in
		      (args:get-arg "-runname"))) ;; eventually get rid of the get-arg calls
	 (testpatt (or (args:get-arg "-testpatt")
		       (and (eq? action 'archive) ;; if it is an archive command fallback to MT_TEST_NAME and MT_ITEMPATH
			    (common:get-full-test-name))
		       (and (eq? action 'kill-runs)
			    "%/%") ;; I'm just guessing that this is correct :(
	 (target (common:args-get-target)))
		       (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")))
		       ))) ;; 
    (cond
     ((not target)
      (debug:print-error 0 *default-log-port* "Missing required parameter for " action ", you must specify -target or -reqtarg")
      (debug:print-error 0 *default-log-port* "Missing required parameter for "
			 action ", you must specify -target or -reqtarg")
      (exit 1))
     ((not (or (args:get-arg ":runname")
	       (args:get-arg "-runname")))
      (debug:print-error 0 *default-log-port* "Missing required parameter for " action ", you must specify the run name pattern with -runname patt")
     ((not runname)
      (debug:print-error 0 *default-log-port* "Missing required parameter for "
			 action ", you must specify the run name pattern with -runname patt")
      (exit 2))
     ((not (or (args:get-arg "-testpatt") (eq? action 'kill-runs)))
      (debug:print-error 0 *default-log-port* "Missing required parameter for " action ", you must specify the test pattern with -testpatt")
     ((not testpatt)
      (debug:print-error 0 *default-log-port* "Missing required parameter for "
			 action ", you must specify the test pattern with -testpatt")
      (exit 3))
     (else
      (if (not (car *configinfo*))
	  (begin
	    (debug:print-error 0 *default-log-port* "Attempted " action "on test(s) but run area config file not found")
	    (exit 1))
	  ;; put test parameters into convenient variables
	  (begin
	    ;; check for correct version, exit with message if not correct
	    (common:exit-on-version-changed)
	    (runs:operate-on  action
			      target
			      (common:args-get-runname)  ;; (or (args:get-arg "-runname")(args:get-arg ":runname"))
			      (common:args-get-testpatt #f) ;; (args:get-arg "-testpatt")
			      state: (common:args-get-state)
			      runname
			      testpatt
			      state:  (common:args-get-state)
			      status: (common:args-get-status)
			      new-state-status: (args:get-arg "-set-state-status")
                              mode: mode)))
      (set! *didsomething* #t)))))

(if (args:get-arg "-kill-runs")
    (general-run-call 




︙


1866
1867
1868
1869
1870
1871
1872
1873

1874
1875
1876
1877
1878
1879
1880

1893
1894
1895
1896
1897
1898
1899

1900
1901
1902
1903
1904
1905
1906
1907








-
+








;; Archive tests matching target, runname, and testpatt
(if (args:get-arg "-archive")
    ;; else do a general-run-call
    (general-run-call 
     "-archive"
     "Archive"
     (lambda (target runname keys keyvals)
       (operate-on 'archive))))
       (operate-on 'archive target-in: target runname-in: runname ))))

;;======================================================================
;; Extract a spreadsheet from the runs database
;;======================================================================

(if (args:get-arg "-extract-ods")
    (general-run-call




︙


2341
2342
2343
2344
2345
2346
2347

2348
2349
2350
2351
2352
2353
2354








2355
2356
2357
2358
2359
2360
2361

2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397








+







+
+
+
+
+
+
+
+








     
(if (args:get-arg "-generate-html")
    (let* ((toppath (launch:setup)))
      (if (tests:create-html-tree #f)
          (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/page0.html")
          (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
      (set! *didsomething* #t)))

(if (args:get-arg "-generate-html-structure")
    (let* ((toppath (launch:setup)))
      ;(if (tests:create-html-tree #f)
 				(if (tests:create-html-summary #f)
          (debug:print-info 0 *default-log-port* "HTML output created in " toppath "/lt/targets.html")
          (debug:print 0 *default-log-port* "Failed to create HTML output in " toppath "/lt/runs-index.html"))
      (set! *didsomething* #t)))

(if (args:get-arg "-syscheck")
    (begin
      (mutils:syscheck common:raw-get-remote-host-load
		       server:get-best-guess-address
		       read-config)
      (set! *didsomething* #t)))

;;======================================================================
;; Exit and clean up
;;======================================================================

(if (not *didsomething*)
    (debug:print 0 *default-log-port* help)
    (set! *time-to-exit* #t)




︙







Added mtargs.scm version [1e6b59e54f].



























1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;;======================================================================
;; Copyright 2019, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================

(declare (unit mtargs))

(include "mtargs/mtargs.scm")








Added mtargs/Makefile version [f71e390f41].


























1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

# Copyright 2007-2010, 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.

# TARGDIR = $(shell csi -e "(print (car \#\#sys\#include-pathnames))(exit)")

all : uptodate.log # $(TARGDIR)/mtargs.so

uptodate.log : mtargs.scm mtargs.setup
	chicken-install | tee uptodate.log

$(TARGDIR)/mtargs.so : mtargs.so
	@echo installing to $(TARGDIR)
	cp mtargs.so $(TARGDIR)

mtargs.so : mtargs.scm
	csc -s mtargs.scm








Added mtargs/mtargs.meta version [65ccfb2eb7].
























1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

(
; Your egg's license:
(license "LGPL")

; Pick one from the list of categories (see below) for your egg and enter it
; here.
(category misc)

; A list of eggs mpeg3 depends on.  If none, you can omit this declaration
; altogether. If you are making an egg for chicken 3 and you need to use
; procedures from the `files' unit, be sure to include the `files' egg in the
; `needs' section (chicken versions < 3.4.0 don't provide the `files' unit).
; `depends' is an alias to `needs'.
(needs srfi-69 srfi-1)

; A list of eggs required for TESTING ONLY.  See the `Tests' section.
(test-depends test)

(author "Matt Welland")
(synopsis "Primitive argument processor."))








Added mtargs/mtargs.scm version [e2f1c247b7].




































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2010, Matthew Welland.
;;
;; This file is part of mtargs.
;; 
;;     mtargs is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     mtargs is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with mtargs.  If not, see <http://www.gnu.org/licenses/>.


(module mtargs
    (
     arg-hash
     get-arg
     get-arg-from
     usage
     get-args
     print-args
     any-defined?
     help
     )

(import scheme chicken data-structures extras posix ports files)
(use srfi-69 srfi-1)

(define arg-hash (make-hash-table))
(define help "")

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

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

;; (define any any-defined?)

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

(define (usage . args)
  (if (> (length args) 0)
      (apply print "ERROR: " args))
  (if (string? help)
      (print help)
      (print "Usage: " (car (argv)) " ... "))
  (exit 0))

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

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


)








Added mtargs/mtargs.setup version [8300885e1f].






















1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2010, 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.

;;;; mtargs.setup

;; compile the code into a dynamically loadable shared object
;; (will generate mtargs.so)
(compile -s mtargs.scm)

;; Install as extension library
(standard-extension 'mtargs "mtargs.so")









Modified mtut.scm
from [b7729a338b]
to [daf0c4d9a4].




︙


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

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








-
+









-
+



-
+








;; (include "common.scm")
;; (include "megatest-version.scm")

;; fake out readline usage of toplevel-command
(define (toplevel-command . a) #f)

(use srfi-1 posix srfi-69 readline ;;  regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras)
   srfi-19  srfi-18 extras format pkts regex regex-case
   srfi-19  srfi-18 extras format regex regex-case
     (prefix dbi dbi:)
     nanomsg)

(declare (uses common))
(declare (uses megatest-version))
(declare (uses margs))
(declare (uses configf))
;; (declare (uses rmt))

(use ducttape-lib)
(import ducttape-lib pkts)

(include "megatest-fossil-hash.scm")

(require-library stml)
(import stml2)

;; stuff for the mapper and checker functions
;;
(define *target-mappers*  (make-hash-table)) 
(define *runname-mappers* (make-hash-table)) 
(define *area-checkers*   (make-hash-table)) 





︙







Added mutils.scm version [cd969aa5f3].



























1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;;======================================================================
;; Copyright 2019, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================

(declare (unit mutils))

(include "mutils/mutils.scm")








Added mutils/Makefile version [6e71a235fc].


























1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

# Copyright 2007-2010, 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.

# TARGDIR = $(shell csi -e "(print (car \#\#sys\#include-pathnames))(exit)")

all : uptodate.log # $(TARGDIR)/mutils.so

uptodate.log : mutils.scm mutils.setup
	chicken-setup | tee uptodate.log

$(TARGDIR)/mutils.so : mutils.so
	@echo installing to $(TARGDIR)
	cp mutils.so $(TARGDIR)

mutils.so : mutils.scm
	csc -s mutils.scm








Added mutils/mutils.meta version [d4f4a25176].
























1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

(
; Your egg's license:
(license "BSD")

; Pick one from the list of categories (see below) for your egg and enter it
; here.
(category misc)

; A list of eggs mpeg3 depends on.  If none, you can omit this declaration
; altogether. If you are making an egg for chicken 3 and you need to use
; procedures from the `files' unit, be sure to include the `files' egg in the
; `needs' section (chicken versions < 3.4.0 don't provide the `files' unit).
; `depends' is an alias to `needs'.
(needs sparse-vectors)

; A list of eggs required for TESTING ONLY.  See the `Tests' section.
(test-depends test)

(author "Matt Welland")
(synopsis "A basic description of the purpose of the egg."))








Added mutils/mutils.scm version [9fa9e34972].


























































































































































































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
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
227
228
229
230
231
232
233
234
235
236
237
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
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2006-2011, Matthew Welland.
;; 
;;  This program is made available under the GNU GPL version 2.0 or
;;  greater. See the accompanying file COPYING for details.
;; 
;;  This program is distributed WITHOUT ANY WARRANTY; without even the
;;  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;  PURPOSE.

;; This is from the perl world, a hash of hashes is a super easy way to keep a handle on
;; lots of disparate data
;;

(module mutils
    *

  (import chicken scheme
	  ;; data-structures posix
	  srfi-1
	  ;; srfi-13
	  srfi-69
	  ports
	  extras
	  regex
	  posix
	  data-structures
	  matchable
	  )

(define (mutils:hierhash-ref hh . keys)
  (if (null? keys)
      #f
      (let loop ((ht   hh)
		 (key  (car keys))
		 (tail (cdr keys)))
	(if (null? tail)
	    (if (hash-table? ht)
		(hash-table-ref/default ht key #f)
		#f)
	    (if (hash-table? ht)
		(loop (hash-table-ref/default ht key #f)
		      (car tail)
		      (cdr tail))
		#f)))))

;; WATCH THE NON-INTUITIVE INTERFACE HERE!!!!
;; val comes first!
;;
(define (mutils:hierhash-set! hh val . keys)
  (if (null? keys)
      #f
      (let loop ((ht    hh)
		 (key  (car keys))
		 (tail (cdr keys)))
	(if (null? tail) ;; last one!
	    (hash-table-set! ht key val)
	    (let ((nh (hash-table-ref/default ht key #f)))
	      (if (not nh)(set! nh (make-hash-table)))
	      (hash-table-set! ht key nh)
	      (loop nh
		    (car tail)
		    (cdr tail)))))))

;; nice little routine to add an item to a list in a hashtable 
;;
(define (mutils:hash-table-add-to-list htbl key item)
  (let ((l (hash-table-ref/default htbl key #f)))
    (if l
	(hash-table-set! htbl key (cons item l))
	(hash-table-set! htbl key (list item)))))

(define (mutils:hash-table-append-to-list htbl key lst)
  (let ((l (hash-table-ref/default htbl key #f)))
    (if l
	(hash-table-set! htbl key (append lst l))
        (hash-table-set! htbl key lst))))

;;======================================================================
;; Utils
;;======================================================================

(define (mutils:file->list fname)
  (let ((fh (open-input-file fname))
	(comment (regexp "^\\s*#"))
	(blank   (regexp "^\\s*$")))
    (let loop ((l   (read-line fh))
	       (res '()))
      (if (eof-object? l)
	  (reverse res)
	  (if (or (string-match comment l)
		  (string-match blank l))
	      (loop (read-line fh) res)
	      (loop (read-line fh) (cons l res)))))))

(use sparse-vectors)

;; this is a simple two dimensional sparse array

;; ONLY TWO DIMENSIONS!!! SEE ARRAY-LIB IF YOUR NEEDS ARE GREATER!!
;;
(define (mutils:make-sparse-array)
  (let ((a (make-sparse-vector)))
    (sparse-vector-set! a 0 (make-sparse-vector))
    a))

(define (mutils:sparse-array? a)
  (and (sparse-vector? a)
       (sparse-vector? (sparse-vector-ref a 0))))

(define (mutils:sparse-array-ref a x y)
  (let ((row (sparse-vector-ref a x)))
    (if row
	(sparse-vector-ref row y)
	#f)))

(define (mutils:sparse-array-set! a x y val)
  (let ((row (sparse-vector-ref a x)))
    (if row
	(sparse-vector-set! row y val)
	(let ((new-row (make-sparse-vector)))
	  (sparse-vector-set! a x new-row)
	  (sparse-vector-set! new-row y val)))))

;; some routines for treating assoc lists a bit like hash tables

(define (mutils:assoc-get/default alist key default)
  (let ((res (assoc key alist)))
    (if (and res (list? res)(> (length res) 1))
	(cadr res)
	default)))

(define (mutils:assoc-get alist key)
  (cadr (assoc key alist)))

(define (mutils:hier-list? @hierlist)
  (and (list? @hierlist)
       (> (length @hierlist) 0)
       (list? (car @hierlist))
       (> (length (car @hierlist)) 1)))

(define (mutils:hier-list-get @hierlist . @path)
  (if (list? @hierlist)
      (let* (($path (car @path))
	     (@rempath (cdr @path))
	     (@match (assoc $path @hierlist)))
	(if @match
	    (if (or (not (list? @rempath))(null? @rempath))
		(cadr @match)
		(apply mutils:hier-list-get (cadr @match) @rempath))
	    #f))
      #f))

(define (mutils:hier-list-put! @hierlist . @path)
  (let* (($path (car @path))
	 (@rempath (cdr @path))
	 ($value   (cadr @path))
	 (@match (assoc $path @hierlist))
	 (@remhierlist (remove (lambda (a)
                                 (equal? a @match))
                               @hierlist))
         (@old-pair (let (($value (mutils:hier-list-get @hierlist $path))) (if $value $value '())))
	 (@new-pair (list $path (if (eq? (length @rempath) 1) 
				    (car @rempath)
				    (apply mutils:hier-list-put! @old-pair @rempath)))))
    (cons @new-pair @remhierlist)))

(define (mutils:hier-list-remove! @hierlist . @path)
  (let (($path (car @path)))
    (if (eq? (length @path) 1)
	(remove (lambda (a)
                  (equal? a (assoc $path @hierlist)))
                @hierlist)
	(let* ((@rempath (cdr @path))
	       (@match (assoc $path @hierlist))
	       (@remhierlist (remove (lambda (a) 
                                       (equal? @match a))
                                     @hierlist))
	       (@old-pair (let (($value (mutils:hier-list-get @hierlist $path))) (if $value $value '())))
	       (@new-pair (list $path (apply mutils:hier-list-remove! @old-pair @rempath))))
	  (cons @new-pair @remhierlist)))))

(define (mutils:keys @hierlist . @path)
  (map (lambda (@l)
	 (if (and (list? @l)(not (null? @l))) 
	     (car @l))) 
       (if (null? @path) @hierlist
	   (apply mutils:hier-list-get @hierlist @path))))

;;======================================================================
;; Other utils
;;======================================================================

(define (check-write-create fpath)
  (and (file-write-access? fpath)
       (let ((fname (conc fpath "/.junk-" (current-seconds) "-" (random 10000))))
	 ;;(print "trying to create/remove " fname)
	 (handle-exceptions
	  exn
	  #f
	  (begin
	    (with-output-to-file fname
	      (lambda ()
		(print "You can delete this file")))
	    (delete-file fname)
	    #t)))))

(define (run-and-return-output cmd . params)
  (let-values (((inp oup pid)
		(process cmd params)))
    (let ((res (with-input-from-port inp read-lines)))
      (let-values (((pidres status estatus)
		    (process-wait pid)))
	(and status (eq? estatus 0) res)))))

(define (confirm-ssh-access-to-host hostname)
  (run-and-return-output "ssh" hostname "uptime"))

(define (check-display dsp)
  (run-and-return-output "xdpyinfo" "-display" dsp))

#;(define (check-display dsp)
  (let-values (((inp oup pid)
		(process "xdpyinfo" `("-display" ,dsp))))
    (let ((res (with-input-from-port inp read-lines)))
      (let-values (((pidres status estatus)
		    (process-wait pid)))
	(and status (eq? estatus 0) res)))))

;; do some sanity checks on the system
;;
(define (mutils:syscheck common:raw-get-remote-host-load
			 server:get-best-guess-address
			 read-config)
  ;; current dir writeable and do megatest.config, runconfigs.config files exist/readable
  (print "Current directory " (current-directory) " writeable: " 
	 (if (check-write-create ".") "yes" "NO"))
  ;; home dir writeable
  (print "Home directory " (get-environment-variable "HOME") " writeable: "
	 (if (check-write-create (get-environment-variable "HOME")) "yes" "NO"))
  ;; /tmp writeable
  (print "/tmp directory writeable: " (if (check-write-create "/tmp") "yes" "NO"))
  ;; load configs
  (print "$DISPLAY set: " (if (get-environment-variable "DISPLAY")
			      (conc  (get-environment-variable "DISPLAY") " yes")
			      "NO"))

  (print "$DISPLAY accessible? "
	  ;; (eq? (system "xdpyinfo -display $DISPLAY &>/dev/null") 0)
	 (if (check-display (get-environment-variable "DISPLAY"))
	     "yes" "NO"))

  (print "Password-less ssh access to localhost: "
	 (if  (confirm-ssh-access-to-host "localhost")
	      "yes"
	      "NO"))

  ;; if I'm in a Megatest area do some checks
  (print "Have megatest.config: "
	 (if (file-exists? "megatest.config")
	     "yes"
	     "NO"))

  (print "Have runconfigs.config: "
	 (if (file-exists? "runconfigs.config")
	     "yes"
	     "NO"))

  (if (file-exists? ".homehost")
      (let* ((homehost (with-input-from-file ".homehost"
			 read-line))
	     (currhost (get-host-name))
	     (bestadrs (server:get-best-guess-address currhost)))
	(print "Have .homehost and it is the localhost: "
	       (if (equal? homehost bestadrs)
		   "yes"
		   (conc ".homehost=" homehost ", localhost=" bestadrs ", NO")))
	(print "Have .homehost and it is reachable via ssh: "
	       (if (confirm-ssh-access-to-host homehost)
		   "yes"
		   "NO"))
	))

  (if (file-exists? "megatest.config")
      (let* ((cdat (read-config "megatest.config" #f #f)))
	(print "Have [disks] section: "
	       (if (hash-table-ref/default cdat "disks" #f)
		   (conc (hash-table-ref cdat "disks") " yes")
		   "NO"))
	(for-each
	 (lambda (entry)
	   (match
	    entry
	    ((dname path)
	     (print "Disk " dname " at " path " writeable: "
		    (if (check-write-create path) "yes" "NO")))
	    (else (print "bad entry: " entry))))
	 (hash-table-ref/default cdat "disks" '()))))

  (print "Have link tree and it is writable: "
	 (if (and (file-exists? "lt")
		  (check-write-create "lt"))
	     "yes"
	     "NO"))
  ;;    check load on homehost
  )

;; Develop stuff here - then move to where it belongs.


)








Added mutils/mutils.setup version [4dd63cdcba].






















1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2010, 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.

;;;; mutils.setup

;; compile the code into a dynamically loadable shared object
;; (will generate mutils.so)
(compile -s mutils.scm)

;; Install as extension library
(install-extension 'mutils "mutils.so")









Added mutils/tests/datastruct.scm version [26239e26a3].



















1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+


(use test)

(include "datastruct.scm")

(define hh (make-hash-table))

(hierhash-set! hh 5 1 2 3 4)

(test 5 (hierhash-ref hh 1 2 3 4))

(hierhash-set! hh 10 1 2 3 5)

(test 10 (hierhash-ref hh 1 2 3 5))
(test 5  (hierhash-ref hh 1 2 3 4))








Added pkts.scm version [4f496b5684].



























1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;;======================================================================
;; Copyright 2019, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================

(declare (unit pkts))

(include "pkts/pkts.scm")








Added pkts/pktrec.scm version [28997466b3].








































































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

(define-syntax define-record-type
  (syntax-rules ()
    ((define-record-type type
       (constructor constructor-tag ...)
       predicate
       (field-tag accessor . more) ...)
     (begin
       (define type
         (make-record-type 'type '(field-tag ...)))
       (define constructor
         (record-constructor type '(constructor-tag ...)))
       (define predicate
         (record-predicate type))
       (define-record-field type field-tag accessor . more)
       ...))))

; An auxilliary macro for define field accessors and modifiers.
; This is needed only because modifiers are optional.

(define-syntax define-record-field
  (syntax-rules ()
    ((define-record-field type field-tag accessor)
     (define accessor (record-accessor type 'field-tag)))
    ((define-record-field type field-tag accessor modifier)
     (begin
       (define accessor (record-accessor type 'field-tag))
       (define modifier (record-modifier type 'field-tag))))))

; Record types

; We define the following procedures:
; 
; (make-record-type <type-name <field-names>)    -> <record-type>
; (record-constructor <record-type<field-names>) -> <constructor>
; (record-predicate <record-type>)               -> <predicate>
; (record-accessor <record-type <field-name>)    -> <accessor>
; (record-modifier <record-type <field-name>)    -> <modifier>
;   where
; (<constructor> <initial-value> ...)         -> <record>
; (<predicate> <value>)                       -> <boolean>
; (<accessor> <record>)                       -> <value>
; (<modifier> <record> <value>)         -> <unspecific>

; Record types are implemented using vector-like records.  The first
; slot of each record contains the record's type, which is itself a
; record.

(define (record-type record)
  (record-ref record 0))

;----------------
; Record types are themselves records, so we first define the type for
; them.  Except for problems with circularities, this could be defined as:
;  (define-record-type :record-type
;    (make-record-type name field-tags)
;    record-type?
;    (name record-type-name)
;    (field-tags record-type-field-tags))
; As it is, we need to define everything by hand.

(define :record-type (make-record 3))
(record-set! :record-type 0 :record-type)	; Its type is itself.
(record-set! :record-type 1 ':record-type)
(record-set! :record-type 2 '(name field-tags))

; Now that :record-type exists we can define a procedure for making more
; record types.

(define (make-record-type name field-tags)
  (let ((new (make-record 3)))
    (record-set! new 0 :record-type)
    (record-set! new 1 name)
    (record-set! new 2 field-tags)
    new))

; Accessors for record types.

(define (record-type-name record-type)
  (record-ref record-type 1))

(define (record-type-field-tags record-type)
  (record-ref record-type 2))

;----------------
; A utility for getting the offset of a field within a record.

(define (field-index type tag)
  (let loop ((i 1) (tags (record-type-field-tags type)))
    (cond ((null? tags)
           (error "record type has no such field" type tag))
          ((eq? tag (car tags))
           i)
          (else
           (loop (+ i 1) (cdr tags))))))

;----------------
; Now we are ready to define RECORD-CONSTRUCTOR and the rest of the
; procedures used by the macro expansion of DEFINE-RECORD-TYPE.

(define (record-constructor type tags)
  (let ((size (length (record-type-field-tags type)))
        (arg-count (length tags))
        (indexes (map (lambda (tag)
                        (field-index type tag))
                      tags)))
    (lambda args
      (if (= (length args)
             arg-count)
          (let ((new (make-record (+ size 1))))
            (record-set! new 0 type)
            (for-each (lambda (arg i)
			(record-set! new i arg))
                      args
                      indexes)
            new)
          (error "wrong number of arguments to constructor" type args)))))

(define (record-predicate type)
  (lambda (thing)
    (and (record? thing)
         (eq? (record-type thing)
              type))))

(define (record-accessor type tag)
  (let ((index (field-index type tag)))
    (lambda (thing)
      (if (and (record? thing)
               (eq? (record-type thing)
                    type))
          (record-ref thing index)
          (error "accessor applied to bad value" type tag thing)))))

(define (record-modifier type tag)
  (let ((index (field-index type tag)))
    (lambda (thing value)
      (if (and (record? thing)
               (eq? (record-type thing)
                    type))
          (record-set! thing index value)
          (error "modifier applied to bad value" type tag thing)))))

Records

; This implements a record abstraction that is identical to vectors,
; except that they are not vectors (VECTOR? returns false when given a
; record and RECORD? returns false when given a vector).  The following
; procedures are provided:
;   (record? <value>)                -> <boolean>
;   (make-record <size>)             -> <record>
;   (record-ref <record> <index>)    -> <value>
;   (record-set! <record> <index> <value>) -> <unspecific>
;
; These can implemented in R5RS Scheme as vectors with a distinguishing
; value at index zero, providing VECTOR? is redefined to be a procedure
; that returns false if its argument contains the distinguishing record
; value.  EVAL is also redefined to use the new value of VECTOR?.

; Define the marker and redefine VECTOR? and EVAL.

(define record-marker (list 'record-marker))

(define real-vector? vector?)

(define (vector? x)
  (and (real-vector? x)
       (or (= 0 (vector-length x))
	   (not (eq? (vector-ref x 0)
		record-marker)))))

; This won't work if ENV is the interaction environment and someone has
; redefined LAMBDA there.

(define eval
  (let ((real-eval eval))
    (lambda (exp env)
      ((real-eval `(lambda (vector?) ,exp))
       vector?))))

; Definitions of the record procedures.

(define (record? x)
  (and (real-vector? x)
       (< 0 (vector-length x))
       (eq? (vector-ref x 0)
            record-marker)))

(define (make-record size)
  (let ((new (make-vector (+ size 1))))
    (vector-set! new 0 record-marker)
    new))

(define (record-ref record index)
  (vector-ref record (+ index 1)))

(define (record-set! record index value)
  (vector-set! record (+ index 1) value))








Added pkts/pkts.meta version [b5255a025d].

























1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; -*- scheme -*-
(
; Your egg's license:
(license "BSD")

; Pick one from the list of categories (see below) for your egg and enter it
; here.
(category db)

; A list of eggs pkts depends on.  If none, you can omit this declaration
; altogether. If you are making an egg for chicken 3 and you need to use
; procedures from the `files' unit, be sure to include the `files' egg in the
; `needs' section (chicken versions < 3.4.0 don't provide the `files' unit).
; `depends' is an alias to `needs'.
;; (needs (autoload "3.0"))

; A list of eggs required for TESTING ONLY.  See the `Tests' section.
(test-depends test)

(author "Matt Welland")
(synopsis "A sha1-chain based datastore built on packets consisting of single line cards modeled loosely on the fossil scm datastore."))








Added pkts/pkts.release-info version [fbbc2937bb].







1
2
3

+
+
+

(repo fossil "http://www.kiatoa.com/cgi-bin/fossils/{egg-name}")
(uri zip "http://www.kiatoa.com/cgi-bin/fossils/{egg-name}/zip/{egg-name}.zip?uuid={egg-release}")
(release "1.0")








Added pkts/pkts.scm version [d1cd1cb6f6].























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
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
227
228
229
230
231
232
233
234
235
236
237
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
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
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
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2006-2017, Matthew Welland.
;; 
;; This file is part of Pkts
;; 
;;     Pkts is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Pkts is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Pkts.  If not, see <http://www.gnu.org/licenses/>.
;;

;; CARDS:
;;
;; A card is a line of text, the first two characters are a letter followed by a
;;   space. The letter is the card type.
;;
;; PKTS:
;;
;; A pkt is a sorted list of cards with a final card Z that contains the shar1 hash
;;   of all of the preceding cards.
;;
;; APKT:
;;
;;  An alist mapping card types to card data
;;      '((T . "pkttype")
;;        (a . "some content"))
;;
;; EPKT:
;;
;;  Extended packet using friendly keys. Must use a pktspec to convert to/from epkts
;;    '((ptype . "pkttype")
;;      (adata . "some content))
;;
;; DPKT:
;;
;; pkts pulled from the database have this format:
;;
;;((apkt (Z . "7de89c09ac024b3832c93e16cd78d11e2e28733b")     <= this is a the alist
;;       (t . "v1.63/tip/dev")
;;       (c . "QUICKPATT")
;;       (T . "runstart")
;;       (P . "354eeb67120a921e3e33155ecab1b522ac10b6bd")
;;       (D . "1488995096.0"))
;;  (id . 8)
;;  (group-id . 0)
;;  (uuid . "7de89c09ac024b3832c93e16cd78d11e2e28733b")
;;  (parent . "")
;;  (pkt-type . "runstart")
;;  (pkt . "D 1488995096.0\nP 354eeb67120a921e3e33155ecab1b522ac10b6bd\nT runstart\nc QUICKPATT\nt v1.63/tip/dev\nZ 7de89c09ac024b3832c93e16cd78d11e2e28733b"))
;;
;; pktspec is alist of alists mapping types and nicekeys to keys
;;
;; '((posting . ((title . t)
;;               (url   . u)
;;               (blurb . b)))
;;   (comment . ((comment . c)
;;               (score   . s))))

;; Reserved cards:
;;   P      : pkt parent
;;   R      : reference pkt containing mapping of short string -> sha1sum strings
;;   T      : pkt type
;;   D      : current time from (current-time), unless provided
;;   Z      : shar1 hash of the packet

;; Example usage:
;;
;; Create a pkt:
;;
;; (use pkts)
;; (define-values (uuid pkt)
;;     (alist->pkt
;;       '((fruit . "apple") (meat . "beef"))  ;; this is the data to convert
;;       '((foods (fruit . f) (meat . m)))     ;; this is the pkt spec
;;       ptype:
;;       'foods))
;;
;; Add to pkt queue:
;;
;; (define db (open-queue-db "/tmp/pkts" "pkts.db"))
;; (add-to-queue db pkt uuid 'foods #f 0) ;; no parent and use group_id of 0
;;
;; Retrieve the packet from the db and extract a value:
;;
;; (alist-ref
;;    'meat
;;    (dpkt->alist
;;         (car (get-dpkts db #f 0 #f))
;;        '((foods (fruit . f)
;;                 (meat . m)))))
;; => "beef"
;;

(module pkts
(
;; cards, util and misc
;; sort-cards
;; calc-shar1
;;
;; low-level constructor procs, exposed only for development/testing, will be removed
construct-sdat
construct-pkt     
card->type/value  
add-z-card

;; queue database procs
open-queue-db
add-to-queue
create-and-queue
lookup-by-uuid
lookup-by-id
get-dpkts
get-not-processed-pkts
get-related
find-pkts
process-pkts
get-descendents
get-ancestors
get-pkts
get-last-descendent
with-queue-db
load-pkts-to-db

;; procs that operate directly on pkts, sdat, apkts, dpkts etc.
pkt->alist    ;; pkt -> apkt (i.e. alist)
pkt->sdat     ;; pkt -> '("a aval" "b bval" ...)
sdat->alist   ;; '("a aval" "b bval"...) -> ((a . "aval")(b . "bval") ...)
dblst->dpkts  ;; convert list of tuples from queue db into dpkts
dpkt->alist   ;; flatten a dpkt into an alist containing all db fields and the pkt alist
dpkts->alists ;; apply dpkt->alist to a list of alists using a pkt-spec
alist->pkt    ;; returns two values uuid, pkt
get-value     ;; looks up a value given a key in a dpkt
flatten-all   ;; merge the list of values from a query which includes a pkt into a flat alist <== really useful!
check-pkt

;; pkt alists
write-alist->pkt
read-pkt->alist

;; archive database
archive-open-db
write-archive-pkts
archive-pkts
mark-processed

;; pktsdb
pktdb-conn     ;; useful
pktdb-fname
pktsdb-open
pktsdb-close
pktsdb-add-record
;; temporary
pktdb-pktspec

;; utility procs
increment-string ;; used to get indexes for strings in ref pkts
make-report      ;; make a .dot file 
)

(import chicken scheme data-structures posix srfi-1 regex srfi-13 srfi-69 ports extras)
(use crypt sha1 message-digest (prefix dbi dbi:) typed-records)

;;======================================================================
;; DATA MANIPULATION UTILS
;;======================================================================

(define-inline (unescape-data data)
  (string-translate* data '(("\\n" . "\n") ("\\\\" . "\\"))))

(define-inline (escape-data data)
  (string-translate* data '(("\n" . "\\n") ("\\" . "\\\\"))))

(define-inline (make-card type data)
  (conc type " " (escape-data (->string data))))

;; reverse an alist for doing pktkey -> external key conversions
;;
(define-inline (reverse-aspec aspec)
  (map (lambda (dat)
	 (cons (cdr dat)(car dat)))
       aspec))

;; add a card to the list of cards, sdat
;; if type is #f return only sdat
;; if data is #f return only sdat
;;
(define-inline (add-card sdat type data)
  (if (and type data)
      (cons (make-card type data) sdat)
      sdat))

;;======================================================================
;; STRING AS FUNKY NUMBER
;;======================================================================

;; NOTE: PTDZ are removed as they are reserved. NB// the R card is not used in a
;;       ref, instead the P parent card is used.
;;       Question: Why does it matter to remove PTDZ?
;;                 To make the ref easier to use the ref strings will be the keys
;;                 so we cannot have overlap with any actual keys. But this is a
;;                 bit silly. What we need to do instead is reject keys of length
;;                 one where the char is in PTDZ
;;
;; This is basically base92
;;
(define string-num-chars (string->list "!#$%&'()*+,-./0123456789:;<=>?@ABCEFGHIJKLMNOQRSUVWXY[\\]^_abcdefghijklmnopqrstuvwxyz{|}~"))
;; "0123456789abcdefghijklmnopqrstuvwxyzABCEFGHIJKLMNOQSUVWXY!#$%&'()*+,-./[]:;<=>?\\^_{}|"))

(define (char-incr inchar)
  (let* ((carry     #f)
	 (next-char (let ((rem (member inchar string-num-chars)))
		      (if (eq? (length rem) 1) ;; we are at the last character in our string-num-chars list
			  (begin
			    (set! carry #t)
			    (car string-num-chars))
			  (cadr rem)))))
    (values next-char carry)))
    
(define (increment-string str)
  (if (string-null? str)
      "0"
      (let ((strlst (reverse (string->list str)))) ;; need to process the string from the lsd
	(list->string
	 (let loop ((hed (car strlst))
		    (tal (cdr strlst))
		    (res '()))
	   (let-values (((newhed carry)(char-incr hed)))
	     ;; (print "newhed: " newhed " carry: " carry " tal: " tal)
	     (let ((newres (cons newhed res)))
	       (if carry ;; we'll have to propagate the carry
		   (if (null? tal) ;; at the end, tack on "0" (which is really a "1")
		       (cons (car string-num-chars) newres)
		       (loop (car tal)(cdr tal) newres))
		   (append (reverse tal) newres)))))))))
    
;;======================================================================
;; P K T S D B   I N T E R F A C E
;;
;; INTEGER, REAL, TEXT
;;======================================================================
;;
;; spec
;;  ( (tablename1 . (field1name L1 TYPE)
;;                  (field2name L2 TYPE) ... )
;;    (tablename2 ... ))
;;
;;  Example: (tests (testname n TEXT)
;;                  (rundir   r TEXT)
;;                   ... )
;;
;; pkt keys are taken from the first letter, if that is not unique
;; then look at the next letter and so on
;;

;; use this struct to hold the pktspec and the db handle
;;
(defstruct pktdb
  (fname       #f)
  (pktsdb-spec #f)
  (pktspec     #f)  ;; cache the pktspec
  (field-keys  #f)  ;; cache the field->key mapping (field1 . k1) ...
  (key-fields  #f)  ;; cache the key->field mapping
  (conn        #f)
  )

;; WARNING: There is a simplification in the pktsdb spec w.r.t. pktspec.
;;          The field specs are the cdr of the table list - not a full
;;          list. The extra list level in pktspec is gratuitous and should
;;          be removed.
;;
(define (pktsdb-spec->pktspec tables-spec)
  (map (lambda (tablespec)
	 (list (car tablespec)
	       (map (lambda (field-spec)
		      (cons (car field-spec)(cadr field-spec)))
		    (cdr tablespec))))
       tables-spec))

(define (pktsdb-open dbfname pktsdb-spec)
  (let* ((pdb      (make-pktdb))
	 (dbexists (file-exists? dbfname))
	 (db       (dbi:open 'sqlite3 `((dbname . ,dbfname)))))
    (pktdb-pktsdb-spec-set! pdb pktsdb-spec)
    (pktdb-pktspec-set!     pdb (pktsdb-spec->pktspec pktsdb-spec))
    (pktdb-fname-set!       pdb dbfname)
    (pktdb-conn-set!        pdb db)
    (if (not dbexists)
	(pktsdb-init pdb))
    pdb))

(define (pktsdb-init pktsdb)
  (let* ((db          (pktdb-conn pktsdb))
	 (pktsdb-spec (pktdb-pktsdb-spec pktsdb)))
    ;; create a table for the pkts themselves
    (dbi:exec db "CREATE TABLE IF NOT EXISTS pkts (id INTEGER PRIMARY KEY, zkey TEXT, record_id INTEGER, pkt TEXT);")
    (for-each
     (lambda (table)
       (let* ((table-name (car table))
	      (fields     (cdr table))
	      (stmt (conc "CREATE TABLE IF NOT EXISTS "
			  table-name
			  " (id INTEGER PRIMARY KEY,"
			  (string-intersperse
			   (map (lambda (fieldspec)
				  (conc (car fieldspec) " "
					(caddr fieldspec)))
				fields)
			   ",")
			  ");")))
	 (dbi:exec db stmt)))
     pktsdb-spec)))

;; create pkt from the data and insert into pkts table
;; 
;; data is assoc list of (field . value) ...
;; tablename is a symbol matching the table name
;;
(define (pktsdb-add-record pktsdb tablename data #!optional (parent #f))
  (let*-values (((zkey pkt) (alist->pkt data (pktdb-pktspec pktsdb) ptype: tablename)))
    ;; have the data as alist so insert it into appropriate table also
    (let* ((db        (pktdb-conn pktsdb)))
      ;; TODO: Address collisions
      (dbi:exec db "INSERT INTO pkts (zkey,pkt,record_id) VALUES (?,?,?);"
		zkey pkt -1)
      (let* (;; (pktid     (pktsdb-pktkey->pktid pktsdb pktkey))
	     (record-id (pktsdb-insert pktsdb tablename data)))
	(dbi:exec db "UPDATE pkts SET record_id=? WHERE zkey=?;"
		  record-id zkey)
      ))))

;; 
(define (pktsdb-insert pktsdb tablename data)
  (let* ((db (pktdb-conn pktsdb))
	 (stmt (conc "INSERT INTO " tablename
		     " (" (string-intersperse (map conc (map car data)) ",")
		     ") VALUES ('"
		     ;; TODO: Add lookup of data type and do not
		     ;;       wrap integers with quotes
		     (string-intersperse (map conc (map cdr data)) "','")
		     "');")))
    (print "stmt: " stmt)
    (dbi:exec db stmt)
    ;; lookup the record-id and return it
    
    ))
    

(define (pktsdb-close pktsdb)
  (dbi:close (pktdb-conn pktsdb)))

;; (let loop ((s "0")(n 0))(print s)(if (< n 5000)(loop (increment-string s)(+ n 1))))

;;======================================================================
;; CARDS, MISC and UTIL
;;======================================================================

;; given string (likely multi-line) "dat" return shar1 hash
;;
(define-inline (calc-shar1 instr)
  (message-digest-string
   (sha1-primitive)
   instr))

;; given a single card return its type and value
;;
(define (card->type/value card)
  (let ((ctype (substring card 0 1))
	(cval  (substring card 2 (string-length card))))
    (values (string->symbol ctype) cval)))

;;======================================================================
;; SDAT procs
;;  sdat is legacy/internal usage. Intention is to remove sdat calls from
;;  the exposed calls.
;;======================================================================

;; sort list of cards
;;
(define-inline (sort-cards sdat)
  (sort sdat string<=?))

;; pkt rules
;; 1. one card per line
;; 2. at least one card
;; 3. no blank lines

;; given sdat, a list of cards return uuid, packet (as sdat)
;;
(define (add-z-card sdat)
  (let* ((sorted-sdat (sort-cards sdat))
	 (dat         (string-intersperse sorted-sdat "\n"))
	 (uuid        (calc-shar1 dat)))
    (values
     uuid
     (conc
      dat
      "\nZ "
      uuid))))

(define (check-pkt pkt)
  (handle-exceptions
      exn
      #f ;; anything goes wrong - call it a crappy pkt
    (let* ((sdat (string-split pkt "\n"))
	   (rdat (reverse sdat)) ;; reversed
	   (zdat (car rdat))
	   (Z    (cadr (string-split zdat)))
	   (cdat (string-intersperse (reverse (cdr rdat)) "\n")))
      (equal? Z (calc-shar1 cdat)))))

;;======================================================================
;; APKTs
;;======================================================================

;; convert a sdat (list of cards) to an alist
;;
(define (sdat->alist sdat)
  (let loop ((hed (car sdat))
	     (tal (cdr sdat))
	     (res '()))
    (let-values (( (ctype cval)(card->type/value hed) ))
      ;; if this card is not one of the common ones tack it on to rem
      (let* ((oldval (alist-ref ctype res))
	     (newres (cons (cons ctype
				 (if oldval ;; list or string
				     (if (list? oldval)
					 (cons cval oldval)
					 (cons cval (list oldval)))
				     cval))
			   res)))
	(if (null? tal)
	    newres
	    (loop (car tal)(cdr tal) newres))))))

;;((apkt (Z . "7de89c09ac024b3832c93e16cd78d11e2e28733b")     <= this is a the alist
;;       (t . "v1.63/tip/dev")
;;       (c . "QUICKPATT")
;;       (T . "runstart")
;;       (P . "354eeb67120a921e3e33155ecab1b522ac10b6bd")
;;       (D . "1488995096.0"))
;;  (id . 8)
;;  (group-id . 0)
;;  (uuid . "7de89c09ac024b3832c93e16cd78d11e2e28733b")
;;  (parent . "")
;;  (pkt-type . "runstart")
;;  (pkt . "D 1488995096.0\nP 354eeb67120a921e3e33155ecab1b522ac10b6bd\nT runstart\nc QUICKPATT\nt v1.63/tip/dev\nZ 7de89c09ac024b3832c93e16cd78d11e2e28733b"))
;;
;; pktspec is alist of alists mapping types and nicekeys to keys
;;
;; '((posting . ((title . t)
;;               (url   . u)
;;               (blurb . b)))
;;   (comment . ((comment . c)
;;               (score   . s))))

;; DON'T USE? 
;;
(define (get-value field dpkt . spec-in)
  (if (null? spec-in)
      (alist-ref field dpkt)
      (let* ((spec  (car spec-in))
	     (apkt  (alist-ref 'apkt dpkt))) ;; get the pkt alist
	(if (and apkt spec)
	    (let* ((ptype (alist-ref 'pkt-type dpkt))
		   (pspec (alist-ref (string->symbol ptype) spec))) ;; do we have a spec for this type of pkt
	      (and pspec
		  (let* ((key (alist-ref field pspec)))
		    (and key (alist-ref key apkt)))))
	    #f))))

;; convert a dpkt to a pure alist given a pktspec
;; this flattens out the alist to include the data from
;; the queue database record
;;
(define (dpkt->alist dpkt pktspec)
  (let* ((apkt       (alist-ref 'apkt dpkt))
	 (pkt-type   (or (alist-ref 'pkt-type dpkt) ;; pkt-type is from the database field pkt_type
			 (alist-ref 'T apkt)))
	 (pkt-fields (alist-ref (string->symbol pkt-type) pktspec))
	 (rev-fields (if pkt-fields
			 (reverse-aspec pkt-fields)
			 '())))
    (append (map (lambda (entry)
		   (let* ((pkt-key (car entry))
			  (new-key (or (alist-ref pkt-key rev-fields) pkt-key)))
		     `(,new-key . ,(cdr entry))))
		 apkt)
	    dpkt)))

;; convert a list of dpkts into a list of alists using pkt-spec
;;
(define (dpkts->alists dpkts pkt-spec)
   (map (lambda (x)
	  (dpkt->alist x pkt-spec))
	dpkts))

;; Generic flattener, make the tuple and pkt into a single flat alist
;;
;; qry-result-spec is a list of symbols corresponding to each field
;;
(define (flatten-all inlst pktspec . qry-result-spec)
  (map
   (lambda (tuple)
     (dpkt->alist
      (apply dblst->dpkts tuple qry-result-spec)
      pktspec))
   inlst))

;; call like this:
;;  (construct-sdat 'a "a data" 'S "S data" ...)
;; returns list of cards
;;  ( "A a value" "D 12345678900" ...)
;;
(define (construct-sdat . alldat)
  (let ((have-D-card #f)) ;; flag
    (if (even? (length alldat))
	(let loop ((type (car alldat))
		   (data (cadr alldat))
		   (tail (cddr alldat))
		   (res  '()))
	  (if (eq? type 'D)(set! have-D-card #t))
	  (if (null? tail)
	      (if have-D-card ;; return the constructed pkt, add a D card if none found
		  (add-card res type data)
		  (add-card 
		   (add-card res 'D (current-seconds))
		   type data))
	      (loop (car tail)
		    (cadr tail)
		    (cddr tail)
		    (add-card res type data))))
	#f))) ;; #f means it failed to create the sdat

(define (construct-pkt . alldat)
  (add-z-card
   (apply construct-sdat alldat)))

;;======================================================================
;; CONVERTERS
;;======================================================================

(define (pkt->sdat pkt)
  (map unescape-data (string-split pkt "\n")))

;; given a pure pkt return an alist
;;
(define (pkt->alist pkt #!key (pktspec #f))
  (let ((sdat (cond
	       ((string? pkt)  (pkt->sdat pkt))
	       ((list? pkt)    pkt)
	       (else #f))))
    (if pkt
	(if pktspec
	    (dpkt->alist (list (cons 'apkt (sdat->alist sdat))) pktspec)
	    (sdat->alist sdat))
	#f)))

;; convert an alist to an sdat
;;  in: '((a . "blah")(b . "foo"))
;; out: '("a blah" "b foo")
;;
(define (alist->sdat adat)
  (map (lambda (dat)
	 (conc (car dat) " " (cdr dat)))
       adat))

;; adat is the incoming alist, aspec is the mapping
;; from incoming key to the pkt key (usually one
;; letter to keep data tight) see the pktspec at the
;; top of this file
;;
;; NOTE: alists can contain multiple instances of the same key (supported fine by pkts)
;;       but you (obviously I suppose) cannot use alist-ref to access those entries.
;;
(define (alist->pkt adat aspec #!key (ptype #f))
  (let* ((pkt-type (or ptype
		       (alist-ref 'T adat) ;; can provide in the incoming alist
		       #f))
	 (pkt-spec (if pkt-type            ;; alist of external-key -> key
		       (or (alist-ref pkt-type aspec) '())
		       (if (null? aspec)
			   '()
			   (cdar aspec)))) ;; default to first one if nothing specified
	 (new-alist (map (lambda (dat)
			   (let* ((key    (car dat))
				  (val    (cdr dat))
				  (newkey (or (alist-ref key pkt-spec)
					      key)))
			     (cons newkey (escape-data (conc val))))) ;; convert all incoming data (symbols, numbers etc.) to a string and then escape newlines.
			 adat))
	 (new-with-type (if (alist-ref 'T new-alist)
			    new-alist
			    (cons `(T . ,pkt-type) new-alist)))
	 (with-d-card   (if (alist-ref 'D new-with-type)
			    new-with-type
			    (cons `(D . ,(current-seconds))
				  new-with-type))))
    (add-z-card
     (alist->sdat with-d-card))))

;;======================================================================
;;  D B   Q U E U E   I N T E R F A C E
;;======================================================================

;; pkts (
;;   id SERIAL PRIMARY KEY,
;;   uuid TEXT NOT NULL,
;;   parent_uuid TEXT default '',
;;   pkt_type INTEGER DEFAULT 0,
;;   group_id INTEGER NOT NULL,
;;   pkt TEXT NOT NULL

;; schema is list of SQL statements - can be used to extend db with more tables
;;
(define (open-queue-db dbpath dbfile #!key (schema '()))
  (let* ((dbfname  (conc dbpath "/" dbfile))
	 (dbexists (if (file-exists? dbfname) #t (begin (create-directory dbpath #t) #f)))
	 (db       (dbi:open 'sqlite3 (list (cons 'dbname dbfname)))))
    ;; (set-busy-handler! db (busy-timeout 10000))
    (if (not dbexists) ;; NOTE: In the archive we allow duplicates and other messiness. 
	(for-each
	 (lambda (stmt)
	   (dbi:exec db stmt))
	 (cons "CREATE TABLE IF NOT EXISTS pkts
                          (id           INTEGER PRIMARY KEY,
                           group_id     INTEGER NOT NULL,
                           uuid         TEXT NOT NULL,
                           parent_uuid  TEXT TEXT DEFAULT '',
                           pkt_type     TEXT NOT NULL,
                           pkt          TEXT NOT NULL,
                           processed    INTEGER DEFAULT 0)"
		   schema))) ;; 0=not processed, 1=processed, 2... for expansion
    db))

(define (add-to-queue db pkt uuid pkt-type parent-uuid group-id)
  (dbi:exec db "INSERT INTO pkts (uuid,parent_uuid,pkt_type,pkt,group_id)
                   VALUES(?,?,?,?,?);" ;; $1,$2,$3,$4,$5);"
	    uuid
	    (if parent-uuid parent-uuid "");; use null string as placeholder for no parent uuid.
	    (if pkt-type (conc pkt-type) "") 
	    pkt
	    group-id))

;; given all needed parameters create a pkt and store it in the queue
;;  procs is an alist that maps pkt-type to a function that takes a list of pkt params
;;  in data and returns the uuid and pkt
;;
(define (create-and-queue conn procs pkt-type parent-uuid group-id data)
  (let ((proc (alist-ref pkt-type procs)))
    (if proc
	(let-values (( (uuid pkt) (proc data) ))
	  (add-to-queue conn pkt uuid pkt-type parent-uuid group-id)
	  uuid)
	#f)))

;; given uuid get pkt, if group-id is specified use it (reduces probablity of
;;     being messed up by a uuid collision)
;;
(define (lookup-by-uuid db pkt-uuid group-id)
  (if group-id
      (dbi:get-one db "SELECT pkt FROM pkts WHERE group_id=? AND uuid=?;" group-id pkt-uuid)
      (dbi:get-one db "SELECT pkt FROM pkts WHERE uuid=?;" pkt-uuid)))
      
;; find a packet by its id
;;
(define (lookup-by-id db id)
  (dbi:get-one db "SELECT pkt FROM pkts WHERE id=?;" id))

;; apply a proc to the open db handle for a pkt db in pdbpath
;;
(define (with-queue-db pdbpath proc #!key (schema #f))
  (cond
   ((not (equal? (file-owner pdbpath)(current-effective-user-id)))
    (print "ERROR: directory " pdbpath " is not owned by " (current-effective-user-name)))
   (else
    (let* ((pdb  (open-queue-db pdbpath "pkts.db"
				schema: schema)) ;;  '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));"))))
	   (res  (proc pdb)))
      (dbi:close pdb)
      res))))

(define (load-pkts-to-db pktsdirs pdbpath #!key (schema #f))
  (with-queue-db
   pdbpath
   (lambda (pdb)
     (for-each
      (lambda (pktsdir) ;; look at all
	(cond
	 ((not (file-exists? pktsdir))
	  (print "ERROR: packets directory " pktsdir " does not exist."))
	 ((not (directory? pktsdir))
	  (print "ERROR: packets directory path " pktsdir " is not a directory."))
	 ((not (file-read-access? pktsdir))
	  (print "ERROR: packets directory path " pktsdir " is not readable."))
	 (else
	  ;; (print "INFO: Loading packets found in " pktsdir)
	  (let ((pkts (glob (conc pktsdir "/*.pkt"))))
	    (for-each
	     (lambda (pkt)
	       (let* ((uuid    (cadr (string-match ".*/([0-9a-f]+).pkt" pkt)))
		      (exists  (lookup-by-uuid pdb uuid #f)))
		 (if (not exists)
		     (let* ((pktdat (string-intersperse
				     (with-input-from-file pkt read-lines)
				     "\n"))
			    (apkt   (pkt->alist pktdat))
			    (ptype  (alist-ref 'T apkt)))
		       (add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0))
		       ;; (debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue"))
		       ;; (debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...")
		     )))
	     pkts)))))
      pktsdirs))))

;;======================================================================
;;  P R O C E S S   P K T S
;;======================================================================

;; given a list of field values pulled from the queue db generate a list
;; of dpkt's
;;
(define (dblst->dpkts lst . altmap)
  (let* ((maplst (if (null? altmap)
		     '(id group-id uuid parent pkt-type pkt processed)
		     altmap))
	 (res (map cons maplst lst))) ;; produces list of pairs, i.e an alist
    (cons `(apkt . ,(pkt->alist (alist-ref 'pkt res)))
	  res)))

;; NB// ptypes is a list of symbols, '() or #f find all types
;;
(define (get-dpkts db ptypes group-id parent-uuid #!key (uuid #f))
  (let* ((ptype-qry (if (and ptypes
			     (not (null? ptypes)))
			(conc " IN ('" (string-intersperse (map conc ptypes) "','") "')")
			(conc " LIKE '%' ")))
	 (rows      (dbi:get-rows
		     db
		     (conc
		      "SELECT id,group_id,uuid,parent_uuid,pkt_type,pkt,processed FROM pkts
                         WHERE pkt_type " ptype-qry " AND group_id=?
                         AND processed=0 "
			 (if parent-uuid (conc "AND parent_uuid='" parent-uuid "' ") "")
			 (if uuid        (conc "AND        uuid='"        uuid "' ") "")
			 "ORDER BY id DESC;")
		     group-id)))
    (map dblst->dpkts (map vector->list rows))))

;; get N pkts not yet processed for group-id
;;
(define (get-not-processed-pkts db group-id pkt-type limit offset)
  (map dblst->dpkts
       (map vector->list
	    (dbi:get-rows
	     db
	     "SELECT id,group_id,uuid,parent_uuid,pkt_type,pkt,processed FROM pkts
                WHERE pkt_type = ? AND group_id = ? AND processed=0
                LIMIT ? OFFSET ?;"
	     (conc pkt-type) ;; convert symbols to string
	     group-id
	     limit
	     offset
	     ))))

;; given a uuid, get not processed child pkts 
;;
(define (get-related db group-id uuid)
  (map dblst->dpkts
       (dbi:get-rows
	db
	"SELECT id,group_id,uuid,parent_uuid,pkt_type,pkt,processed FROM pkts
           WHERE parent_uuid=? AND group_id=? AND processed=0;"
	uuid group-id)))

;; generic pkt processor
;;
;; find all packets in group-id of type in ptypes and apply proc to pktdat
;;
(define (process-pkts conn group-id ptypes parent-uuid proc)
  (let* ((pkts (get-dpkts conn ptypes group-id parent-uuid)))
    (map proc pkts)))

;; criteria is an alist ((k . valpatt) ...)
;;   - valpatt is a regex
;;   - ptypes is a list of types (symbols expected)
;;   match-type: 'any or 'all
;;
(define (find-pkts db ptypes criteria #!key (processed #f)(match-type 'any)(pkt-spec #f)) ;; processed=#f, don't use, else use
  (let* ((pkts (get-dpkts db ptypes 0 #f))
	 (match-rules (lambda (pktdat) ;; returns a list of matching rules
			(filter (lambda (c)
				  ;; (print "c: " c)
				  (let* ((ctype (car c)) ;; card type
					 (rx    (cdr c)) ;; card pattern
					 ;; (t     (alist-ref 'pkt-type pktdat))
					 (pkt   (alist-ref 'pkt pktdat))
					 (apkt  (pkt->alist pkt))
					 (cdat  (alist-ref ctype apkt)))
				    ;; (print "cdat: " cdat) ;; " apkt: " apkt)
				    (if cdat
					(string-match rx cdat)
					#f)))
				criteria)))
	 (res         (filter (lambda (pktdat)
				(if (null? criteria) ;; looking for all pkts
				    #t
				    (case match-type
				      ((any)(not (null? (match-rules pktdat))))
				      ((all)(eq? (length (match-rules pktdat))(length criteria)))
				      (else
				       (print "ERROR: bad match type " match-type ", expecting any or all.")))))
			      pkts)))
    (if pkt-spec
	(dpkts->alists res pkt-spec)
	res)))

;; get descendents of parent-uuid
;;
;; NOTE: Should be doing something like the following:
;;
;; given a uuid, get not processed child pkts 
;; processed:
;;    #f => get all
;;     0 => get not processed
;;     1 => get processed
;;
(define (get-ancestors db group-id uuid #!key (processed #f))
  (map dblst->dpkts
       (map vector->list
	    (dbi:get-rows
	     db
	     (conc
	      "SELECT id,group_id,uuid,parent_uuid,pkt_type,pkt,processed 
                FROM pkts
                 WHERE uuid IN 
                     (WITH RECURSIVE
                       tree(uuid,parent_uuid)
                        AS
                        (
                           SELECT uuid, parent_uuid
                           FROM pkts
                           WHERE uuid = ?
                           UNION ALL
                           SELECT t.uuid, t.parent_uuid
                           FROM pkts t
                           JOIN tree ON t.uuid = tree.parent_uuid
                        )
	              SELECT uuid FROM tree)
	    AND group_id=?" (if processed (conc " AND processed=" processed) "") ";")
	     uuid group-id))))

;; Untested
;;
(define (get-descendents db group-id uuid #!key (processed #f))
  (map dblst->dpkts
       (map vector->list
	    (dbi:get-rows
	     db
	     (conc
	      "SELECT id,group_id,uuid,parent_uuid,pkt_type,pkt,processed 
                FROM pkts
                 WHERE uuid IN 
                     (WITH RECURSIVE
                       tree(uuid,parent_uuid)
                        AS
                        (
                           SELECT uuid, parent_uuid
                           FROM pkts
                           WHERE uuid = ?
                           UNION ALL
                           SELECT t.uuid, t.parent_uuid
                           FROM pkts t
                           JOIN tree ON t.parent_uuid = tree.uuid
                        )
	              SELECT uuid FROM tree)
	    AND group_id=?" (if processed (conc " AND processed=" processed) "") ";")
	     uuid group-id))))

;; look up descendents based on given info unless passed in a list via inlst
;;
(define (get-last-descendent db group-id uuid #!key (processed #f)(inlst #f))
  (let ((descendents (or inlst (get-descendents db group-id uuid processed: processed))))
    (if (null? descendents)
	#f
	(last descendents))))

;;======================================================================
;;  A R C H I V E S - always to a sqlite3 db 
;;======================================================================

;; open an archive db
;; path: archive-dir/<year>/month.db
;;
(define (archive-open-db archive-dir)
  (let* ((curr-time (seconds->local-time (current-seconds)))
	 (dbpath    (conc archive-dir "/" (time->string curr-time "%Y")))
	 (dbfile    (conc dbpath "/" (time->string curr-time "%m") ".db"))
	 (dbexists (if (file-exists? dbfile) #t (begin (create-directory dbpath #t) #f))))
    (let ((db (dbi:open 'sqlite3 (list (cons 'dbname dbfile)))))
      ;; (set-busy-handler! db (busy-timeout 10000))
      (if (not dbexists) ;; NOTE: In the archive we allow duplicates and other messiness. 
	  (dbi:exec db "CREATE TABLE IF NOT EXISTS pkts
                          (id           INTEGER,
                           group_id     INTEGER,
                           uuid         TEXT,
                           parent_uuid  TEXT,
                           pkt_type     TEXT,
                           pkt          TEXT,
                           processed    INTEGER DEFAULT 0)"))
      db)))

;; turn on transactions! otherwise this will be painfully slow
;;
(define (write-archive-pkts src-db db pkt-ids)
  (let ((pkts (dbi:get-rows
	       src-db
	       (conc "SELECT id,group_id,uuid,parent_uuid,pkt_type,pkt FROM pkts WHERE id IN ("
		     (string-intersperse (map conc pkt-ids) ",") ")"))))
    ;; (dbi:with-transaction
    ;;  db
     (lambda ()
       (for-each
	(lambda (pkt)
	  (apply dbi:exec  db "INSERT INTO pkts (id,group_id,uuid,parent_uuid,pkt_type,pkt)
                               VALUES (?,?,?,?,?,?)"
		 pkt))
	pkts)))) ;; )

;; given a list of uuids and lists of uuids move all to
;; the sqlite3 db for the current archive period
;;
(define (archive-pkts conn pkt-ids archive-dir)
  (let ((db (archive-open-db archive-dir)))
    (write-archive-pkts conn db pkt-ids)
    (dbi:close db))
  ;; (pg:with-transaction
  ;;  conn
  ;; (lambda ()
     (for-each
      (lambda (id)
	(dbi:get-one
	 conn
	 "DELETE FROM pkts WHERE id=?" id))
      pkt-ids)) ;; ))

;; given a list of ids mark all as processed
;;
(define (mark-processed conn pkt-ids)
  ;; (pg:with-transaction
   ;; conn
   ;; (lambda ()
     (for-each
      (lambda (id)
	(dbi:get-one
	 conn
	 "UPDATE pkts SET processed=1 WHERE id=?;" id))
      pkt-ids)) ;; x))

;; a generic pkt getter, gets from the pkts db
;;
(define (get-pkts conn ptypes)
  (let* ((ptypes-str    (if (null? ptypes)
			    ""
			    (conc " WHERE pkt_type IN ('" (string-intersperse ptypes ",") "') ")))
	 (qry-str       (conc "SELECT id,group_id,uuid,parent_uuid,pkt_type,pkt,processed FROM pkts" ptypes-str)))
    (map vector->list (dbi:get-rows conn qry-str))))

;; make a report of the pkts in the db
;; ptypes of '() gets all pkts
;; display-fields
;;
(define (make-report dest conn pktspec display-fields . ptypes)
  (let* (;; (conn          (dbi:db-conn (s:db)))
	 (all-rows      (get-pkts conn ptypes))
	 (all-pkts      (flatten-all
			 all-rows
			 pktspec
			 'id 'group-id 'uuid 'parent 'pkt-type 'pkt 'processed))
	 (by-uuid       (let ((ht (make-hash-table)))
			  (for-each
			   (lambda (pkt)
			     (let ((uuid (alist-ref 'uuid pkt)))
			       (hash-table-set! ht uuid pkt)))
			   all-pkts)
			  ht))
	 (by-parent     (let ((ht (make-hash-table)))
			  (for-each
			   (lambda (pkt)
			     (let ((parent (alist-ref 'parent pkt)))
			       (hash-table-set! ht parent (cons pkt (hash-table-ref/default ht parent '())))))
			   all-pkts)
			    ht))
	 (oup           (if dest (open-output-file dest) (current-output-port))))
    
    (with-output-to-port
	oup
      (lambda ()
	(print "digraph megatest_state_status {
  // ranksep=0.05
  rankdir=LR;
  node [shape=\"box\"];
")
	;; first all the names
	(for-each
	 (lambda (pkt)
	   (let* ((uuid        (alist-ref 'uuid pkt))
		  (shortuuid   (substring uuid 0 4))
		  (type        (alist-ref 'pkt-type pkt))
		  (processed   (alist-ref 'processed pkt)))
	     
	     (print "\"" uuid "\" [label=\"" shortuuid ", ("
		    type ", "
		    (if processed "processed" "not processed") ")")
	     (for-each
	      (lambda (key-field)
		(let ((val (alist-ref key-field pkt)))
		  (if val
		      (print key-field "=" val))))
	      display-fields)
	     (print "\" ];")))
	 all-pkts)
	;; now for parent-child relationships
	(for-each
	 (lambda (pkt)
	   (let ((uuid   (alist-ref 'uuid pkt))
		 (parent (alist-ref 'parent pkt)))
	     (if (not (equal? parent ""))
		 (print "\"" parent "\" -> \"" uuid"\";"))))
	 all-pkts)

	(print "}")
	))
    (if dest
	(begin
	  (close-output-port oup)
	  (system "dot -Tpdf out.dot -o out.pdf")))
    
    ))

;;======================================================================
;; Read ref pkts into a vector < laststr hash table > 
;;======================================================================



;;======================================================================
;; Read/write packets to files (convience functions)
;;======================================================================

;; write alist to a pkt file
;;
(define (write-alist->pkt targdir dat #!key (pktspec '())(ptype #f))
  (let-values (((uuid pkt)(alist->pkt dat pktspec ptype: ptype)))
    (with-output-to-file (conc targdir "/" uuid ".pkt")
      (lambda ()
	(print pkt)))
    uuid)) ;; return the uuid

;; read pkt into alist
;;
(define (read-pkt->alist pkt-file #!key (pktspec #f))
  (pkt->alist (with-input-from-file
		  pkt-file
		read-string)
	      pktspec: pktspec))


) ;; module pkts








Added pkts/pkts.setup version [bf666feb42].















1
2
3
4
5
6
7
8
9
10
11

+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2017, 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.

;;;; pkts.setup
(standard-extension 'pkts "1.0")








Added pkts/tests/run.scm version [957c7c2ae2].















































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

(use test)

;; (use (prefix pkts pkts:))
(use pkts (prefix dbi dbi:))
;; (use trace)(trace sdat->alist pkt->alist)

(if (file-exists? "queue.db")(delete-file "queue.db"))

(test-begin "pkts and pkt archives")

;;======================================================================
;; Basic pkt creation, parsing and conversion routines
;;======================================================================

(test-begin "basic packets")
(test #f '(A "This is a packet") (let-values (((t v)
					       (card->type/value "A This is a packet")))
				   (list t v)))
(test #f "A A\nZ 664449e7299e0065a3e25c138ccef2df13ba291e"
      (let-values (((uuid res)
		    (add-z-card '("A A"))))
	res))
(test #f '("CC C++" "D 1486332719.0" "a A" "b C")(sort (construct-sdat 'b "C" 'a "A" 'CC "C++" 'D 1486332719.0)
						       string<=?))
(define pkt-example #f)
(test #f "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84"
      (let-values (((uuid res)
		    (construct-pkt 'b "C" 'a "A" 'CC "C++" 'D 1486332719.0)))
	(set! pkt-example (cons uuid res))
	res))
(test-end "basic packets")

;;======================================================================
;; Sqlite and postgresql based queue of pkts
;;======================================================================

(test-begin "pkt queue")
(define db #f)
(test #f 'sqlite3 (let ((dbh (open-queue-db "." "queue.db")))
		    (set! db dbh)
		    (dbi:db-dbtype dbh)))
(test #f (cdr pkt-example)
      (begin
	(add-to-queue db (cdr pkt-example)(car pkt-example) 'basic #f 0)
	(lookup-by-uuid db (car pkt-example) 0)))
(test #f (cdr pkt-example)
      (lookup-by-id db 1))
(test #f 1 (length (find-pkts db '(basic) '())))

(test-end "pkt queue")


;;======================================================================
;; Process groups of pkts
;;======================================================================

(test-begin "lists of packets")
(test #f '((apkt . #f) (id . 1) (group-id . 2) (uuid . 3) (parent . 4) (pkt-type . 5)) ;; ((id . 1) (group-id . 2) (uuid . 3) (parent . 4) (pkt-type . 5))
      (dblst->dpkts '(1 2 3 4 5)))
(test #f '(((apkt (Z . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (b . "C") (a . "A") (D . "1486332719.0") (C . " C++")) (id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (processed . 0)))
      ;; '(((apkt (Z . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (b . "C") (a . "A") (D . "1486332719.0") (C . " C++")) (id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84")))
      ;; '(((id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84")))
      (get-dpkts db '(basic) 0 #f))
(test #f '(((apkt (Z . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (b . "C") (a . "A") (D . "1486332719.0") (C . " C++")) (id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (processed . 0)))
      ;; '(((apkt (Z . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (b . "C") (a . "A") (D . "1486332719.0") (C . " C++")) (id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84")))
      ;; '(((id . 1) (group-id . 0) (uuid . "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84") (parent . "") (pkt-type . "basic") (pkt . "CC C++\nD 1486332719.0\na A\nb C\nZ 263eb3b6193de7fe65b1ded5bcda513e8b4d6b84")))
      (get-not-processed-pkts db 0 'basic 1000 0))
(test-end "lists of packets")

(test-begin "pkts as alists")
(define pktspec '((posting . ((title . t)   ;; NOTE: same as ((posting (title . t)(url . u)(blub . b)) ... 
			      (url   . u)
			      (blurb . b)))
		  (comment . ((comment . c)
			      (score   . s)))
		  (basic   . ((b-field . b)
			      (a-field . a)))))
(define pktlst (find-pkts db '(basic) '()))
(define dpkt (car pktlst))
(test #f "A" (get-value 'a-field dpkt pktspec))

(test #f "C" (alist-ref 'b-field (dpkt->alist dpkt pktspec)))

(define basic-spec '((nada (foo . b)(bar . f))(basic (foo . f)(bar . b))))
(define test-pkt   '((foo . "fooval")(bar . "barval")))
(let*-values (((u p)  (alist->pkt test-pkt basic-spec ptype: 'basic))
		((apkt) (pkt->alist p))
		((bpkt) (pkt->alist p pktspec: basic-spec)))
    (test #f "fooval" (alist-ref 'f apkt))
    (test #f "fooval" (alist-ref 'foo bpkt))
    (test #f #f       (alist-ref 'f   bpkt)))

(test-end "pkts as alists")

(test-begin "descendents and ancestors")

(define (get-uuid pkt)(alist-ref 'uuid pkt))

;; add a child to 263e
(let-values (((uuid pkt)
	      (construct-pkt 'x "X" 'y "Y" 'P "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84"
			     'D "1486332719.0")))
  (add-to-queue db pkt uuid 'basic "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84" 0))

(test #f '("263eb3b6193de7fe65b1ded5bcda513e8b4d6b84" "818fe30988c9673441b8f203972a8bda6af682f8")
      (map (lambda (x)(alist-ref 'uuid x))
	   (get-descendents
	    db 0
	    "263eb3b6193de7fe65b1ded5bcda513e8b4d6b84")))

(test #f '("263eb3b6193de7fe65b1ded5bcda513e8b4d6b84" "818fe30988c9673441b8f203972a8bda6af682f8")
      (map (lambda (x)(alist-ref 'uuid x))
	   (get-ancestors
	    db 0
	    "818fe30988c9673441b8f203972a8bda6af682f8")))

(test-end "descendents and ancestors")

(test-end "pkts and pkt archives")

(test-begin "pktsdb")

(define spec '((tests (testname n TEXT)
		      (testpath p TEXT)
		      (duration d INTEGER))))
;; (define pktsdb (make-pktdb))
;; (pktdb-pktsdb-spec-set! pktsdb spec)

(define pktsdb #f)

(test #f #t (dbi:database? (let ((pdb (pktsdb-open "test.db" spec)))
			     (set! pktsdb pdb)
			     (pktdb-conn pdb))))
;; (pp (pktdb-pktspec pktsdb))
(test #f #t (pktsdb-add-record pktsdb 'tests '((testname . "test1"))))

(pktsdb-close pktsdb)

(test-end "pktsdb")








Modified rmt.scm
from [63fb23d391]
to [8ff320805f].




︙


556
557
558
559
560
561
562



563
564
565
566
567
568
569

556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572








+
+
+








  ;; (if (number? run-id)
  (rmt:send-receive 'get-tests-for-run run-id (list run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode)))
  ;;    (begin
  ;;	(debug:print-error 0 *default-log-port* "rmt:get-tests-for-run called with bad run-id=" run-id)
  ;;	(print-call-chain (current-error-port))
  ;;	'())))

(define (rmt:get-tests-for-run-state-status run-id testpatt last-update)
  (rmt:send-receive 'get-tests-for-run-state-status run-id (list run-id testpatt last-update)))

;; get stuff via synchash 
(define (rmt:synchash-get run-id proc synckey keynum params)
  (rmt:send-receive 'synchash-get run-id (list run-id proc synckey keynum params)))

(define (rmt:get-tests-for-run-mindata run-id testpatt states status not-in)
  (rmt:send-receive 'get-tests-for-run-mindata run-id (list run-id testpatt states status not-in)))
  




︙


733
734
735
736
737
738
739
740
741


742
743
744
745
746
747
748

736
737
738
739
740
741
742


743
744
745
746
747
748
749
750
751








-
-
+
+









(define (rmt:delete-old-deleted-test-records)
  (rmt:send-receive 'delete-old-deleted-test-records #f '()))

(define (rmt:get-runs runpatt count offset keypatts)
  (rmt:send-receive 'get-runs #f (list runpatt count offset keypatts)))

(define (rmt:simple-get-runs runpatt count offset target)
  (rmt:send-receive 'simple-get-runs #f (list runpatt count offset target)))
(define (rmt:simple-get-runs runpatt count offset target last-update)
  (rmt:send-receive 'simple-get-runs #f (list runpatt count offset target last-update)))

(define (rmt:get-all-run-ids)
  (rmt:send-receive 'get-all-run-ids #f '()))

(define (rmt:get-prev-run-ids run-id)
  (rmt:send-receive 'get-prev-run-ids #f (list run-id)))





︙







Modified runs.scm
from [6cea658ad9]
to [f48ffb3bcd].




︙


2010
2011
2012
2013
2014
2015
2016
2017

2018
2019
2020
2021
2022
2023
2024

2010
2011
2012
2013
2014
2015
2016

2017
2018
2019
2020
2021
2022
2023
2024








-
+








;;
(define (runs:get-hash-by-target target-patts runpatt)
  (let* ((targets (string-split target-patts ","))
	 (keys    (rmt:get-keys))
	 (res-ht  (make-hash-table))) ;; target -> ( runrecord1 runrecord2 ... )
    (for-each
     (lambda (target-patt)
       (let ((runs     (rmt:simple-get-runs runpatt #f #f target-patt)))
       (let ((runs     (rmt:simple-get-runs runpatt #f #f target-patt #f)))
	 (for-each
	  (lambda (run)
	    (let ((target (simple-run-target run)))
	      (hash-table-set! res-ht target (cons run (hash-table-ref/default res-ht target '())))))
	  runs)))
     targets)
    res-ht))




︙


2167
2168
2169
2170
2171
2172
2173
2174


2175
2176

2177
2178



2179
2180
2181


2182
2183
2184
2185
2186
2187
2188

2167
2168
2169
2170
2171
2172
2173

2174
2175
2176

2177
2178

2179
2180
2181
2182


2183
2184
2185
2186
2187
2188
2189
2190
2191








-
+
+

-
+

-
+
+
+

-
-
+
+








		   ((run-wait)
		    (debug:print 1 *default-log-port* "Waiting for run " runkey ", run=" runnamepatt " to complete"))
		   ((archive)
		    (debug:print 1 *default-log-port* "Archiving/restoring (" (args:get-arg "-archive") ") data for run: " runkey " " (db:get-value-by-header run header "runname"))
		    (set! worker-thread
			  (make-thread
			   (lambda ()
			     (case (string->symbol (args:get-arg "-archive"))
			     (let ((op (string->symbol (args:get-arg "-archive"))))
			       (case op
			       ((save save-remove keep-html)
				(archive:run-bup (args:get-arg "-archive") run-id run-name tests rp-mutex bup-mutex))
				(archive:run-bup op run-id run-name tests rp-mutex bup-mutex))
			       ((restore)
				(archive:bup-restore (args:get-arg "-archive") run-id run-name tests rp-mutex bup-mutex))
				(archive:bup-restore op run-id run-name tests rp-mutex bup-mutex))
			       ((get)
				(archive:bup-get-data op run-id run-name tests rp-mutex bup-mutex))
			       (else 
				(debug:print-error 0 *default-log-port* "unrecognised sub command to -archive. Run \"megatest\" to see help")
				(exit))))
				(debug:print-error 0 *default-log-port* "unrecognised sub command " op " for -archive. Run \"megatest\" to see help")
				(exit)))))
			   "archive-bup-thread"))
		    (thread-start! worker-thread))
		   (else
		    (debug:print-info 0 *default-log-port* "action not recognised " action)))
		 
		 ;; actions that operate on one test at a time can be handled below
		 ;;




︙


2498
2499
2500
2501
2502
2503
2504
2505

2506
2507
2508
2509
2510
2511
2512

2501
2502
2503
2504
2505
2506
2507

2508
2509
2510
2511
2512
2513
2514
2515








-
+








;;======================================================================
;; Routines for manipulating runs
;;======================================================================

;; Since many calls to a run require pretty much the same setup 
;; this wrapper is used to reduce the replication of code
(define (general-run-call switchname action-desc proc)
  (let ((runname (or (args:get-arg "-runname")(args:get-arg ":runname")))
  (let ((runname (common:args-get-runname))
	(target  (common:args-get-target)))
    (cond
     ((not target)
      (debug:print-error 0 *default-log-port* "Missing required parameter for " switchname ", you must specify the target with -target")
      (exit 3))
     ((not runname)
      (debug:print-error 0 *default-log-port* "Missing required parameter for " switchname ", you must specify the run name with -runname runname")




︙







Added stml2.scm version [63b057818a].



























1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;;======================================================================
;; Copyright 2019, Matthew Welland.
;; 
;; This file is part of Megatest.
;; 
;;     Megatest is free software: you can redistribute it and/or modify
;;     it under the terms of the GNU General Public License as published by
;;     the Free Software Foundation, either version 3 of the License, or
;;     (at your option) any later version.
;; 
;;     Megatest is distributed in the hope that it will be useful,
;;     but WITHOUT ANY WARRANTY; without even the implied warranty of
;;     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;     GNU General Public License for more details.
;; 
;;     You should have received a copy of the GNU General Public License
;;     along with Megatest.  If not, see <http://www.gnu.org/licenses/>.

;;======================================================================

(declare (unit stml2))

(include "stml2/stml2.scm")








Added stml2/COPYING version [7d7e3bd444].
























































































































































































































































































































































































































































































































































































































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
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
227
228
229
230
231
232
233
234
235
236
237
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
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
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
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

		    GNU GENERAL PUBLIC LICENSE
		       Version 2, June 1991

 Copyright (C) 1989, 1991 Free Software Foundation, Inc.
                       51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
 Everyone is permitted to copy and distribute verbatim copies
 of this license document, but changing it is not allowed.

			    Preamble

  The licenses for most software are designed to take away your
freedom to share and change it.  By contrast, the GNU General Public
License is intended to guarantee your freedom to share and change free
software--to make sure the software is free for all its users.  This
General Public License applies to most of the Free Software
Foundation's software and to any other program whose authors commit to
using it.  (Some other Free Software Foundation software is covered by
the GNU Library General Public License instead.)  You can apply it to
your programs, too.

  When we speak of free software, we are referring to freedom, not
price.  Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
this service if you wish), that you receive source code or can get it
if you want it, that you can change the software or use pieces of it
in new free programs; and that you know you can do these things.

  To protect your rights, we need to make restrictions that forbid
anyone to deny you these rights or to ask you to surrender the rights.
These restrictions translate to certain responsibilities for you if you
distribute copies of the software, or if you modify it.

  For example, if you distribute copies of such a program, whether
gratis or for a fee, you must give the recipients all the rights that
you have.  You must make sure that they, too, receive or can get the
source code.  And you must show them these terms so they know their
rights.

  We protect your rights with two steps: (1) copyright the software, and
(2) offer you this license which gives you legal permission to copy,
distribute and/or modify the software.

  Also, for each author's protection and ours, we want to make certain
that everyone understands that there is no warranty for this free
software.  If the software is modified by someone else and passed on, we
want its recipients to know that what they have is not the original, so
that any problems introduced by others will not reflect on the original
authors' reputations.

  Finally, any free program is threatened constantly by software
patents.  We wish to avoid the danger that redistributors of a free
program will individually obtain patent licenses, in effect making the
program proprietary.  To prevent this, we have made it clear that any
patent must be licensed for everyone's free use or not licensed at all.

  The precise terms and conditions for copying, distribution and
modification follow.

		    GNU GENERAL PUBLIC LICENSE
   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION

  0. This License applies to any program or other work which contains
a notice placed by the copyright holder saying it may be distributed
under the terms of this General Public License.  The "Program", below,
refers to any such program or work, and a "work based on the Program"
means either the Program or any derivative work under copyright law:
that is to say, a work containing the Program or a portion of it,
either verbatim or with modifications and/or translated into another
language.  (Hereinafter, translation is included without limitation in
the term "modification".)  Each licensee is addressed as "you".

Activities other than copying, distribution and modification are not
covered by this License; they are outside its scope.  The act of
running the Program is not restricted, and the output from the Program
is covered only if its contents constitute a work based on the
Program (independent of having been made by running the Program).
Whether that is true depends on what the Program does.

  1. You may copy and distribute verbatim copies of the Program's
source code as you receive it, in any medium, provided that you
conspicuously and appropriately publish on each copy an appropriate
copyright notice and disclaimer of warranty; keep intact all the
notices that refer to this License and to the absence of any warranty;
and give any other recipients of the Program a copy of this License
along with the Program.

You may charge a fee for the physical act of transferring a copy, and
you may at your option offer warranty protection in exchange for a fee.

  2. You may modify your copy or copies of the Program or any portion
of it, thus forming a work based on the Program, and copy and
distribute such modifications or work under the terms of Section 1
above, provided that you also meet all of these conditions:

    a) You must cause the modified files to carry prominent notices
    stating that you changed the files and the date of any change.

    b) You must cause any work that you distribute or publish, that in
    whole or in part contains or is derived from the Program or any
    part thereof, to be licensed as a whole at no charge to all third
    parties under the terms of this License.

    c) If the modified program normally reads commands interactively
    when run, you must cause it, when started running for such
    interactive use in the most ordinary way, to print or display an
    announcement including an appropriate copyright notice and a
    notice that there is no warranty (or else, saying that you provide
    a warranty) and that users may redistribute the program under
    these conditions, and telling the user how to view a copy of this
    License.  (Exception: if the Program itself is interactive but
    does not normally print such an announcement, your work based on
    the Program is not required to print an announcement.)

These requirements apply to the modified work as a whole.  If
identifiable sections of that work are not derived from the Program,
and can be reasonably considered independent and separate works in
themselves, then this License, and its terms, do not apply to those
sections when you distribute them as separate works.  But when you
distribute the same sections as part of a whole which is a work based
on the Program, the distribution of the whole must be on the terms of
this License, whose permissions for other licensees extend to the
entire whole, and thus to each and every part regardless of who wrote it.

Thus, it is not the intent of this section to claim rights or contest
your rights to work written entirely by you; rather, the intent is to
exercise the right to control the distribution of derivative or
collective works based on the Program.

In addition, mere aggregation of another work not based on the Program
with the Program (or with a work based on the Program) on a volume of
a storage or distribution medium does not bring the other work under
the scope of this License.

  3. You may copy and distribute the Program (or a work based on it,
under Section 2) in object code or executable form under the terms of
Sections 1 and 2 above provided that you also do one of the following:

    a) Accompany it with the complete corresponding machine-readable
    source code, which must be distributed under the terms of Sections
    1 and 2 above on a medium customarily used for software interchange; or,

    b) Accompany it with a written offer, valid for at least three
    years, to give any third party, for a charge no more than your
    cost of physically performing source distribution, a complete
    machine-readable copy of the corresponding source code, to be
    distributed under the terms of Sections 1 and 2 above on a medium
    customarily used for software interchange; or,

    c) Accompany it with the information you received as to the offer
    to distribute corresponding source code.  (This alternative is
    allowed only for noncommercial distribution and only if you
    received the program in object code or executable form with such
    an offer, in accord with Subsection b above.)

The source code for a work means the preferred form of the work for
making modifications to it.  For an executable work, complete source
code means all the source code for all modules it contains, plus any
associated interface definition files, plus the scripts used to
control compilation and installation of the executable.  However, as a
special exception, the source code distributed need not include
anything that is normally distributed (in either source or binary
form) with the major components (compiler, kernel, and so on) of the
operating system on which the executable runs, unless that component
itself accompanies the executable.

If distribution of executable or object code is made by offering
access to copy from a designated place, then offering equivalent
access to copy the source code from the same place counts as
distribution of the source code, even though third parties are not
compelled to copy the source along with the object code.

  4. You may not copy, modify, sublicense, or distribute the Program
except as expressly provided under this License.  Any attempt
otherwise to copy, modify, sublicense or distribute the Program is
void, and will automatically terminate your rights under this License.
However, parties who have received copies, or rights, from you under
this License will not have their licenses terminated so long as such
parties remain in full compliance.

  5. You are not required to accept this License, since you have not
signed it.  However, nothing else grants you permission to modify or
distribute the Program or its derivative works.  These actions are
prohibited by law if you do not accept this License.  Therefore, by
modifying or distributing the Program (or any work based on the
Program), you indicate your acceptance of this License to do so, and
all its terms and conditions for copying, distributing or modifying
the Program or works based on it.

  6. Each time you redistribute the Program (or any work based on the
Program), the recipient automatically receives a license from the
original licensor to copy, distribute or modify the Program subject to
these terms and conditions.  You may not impose any further
restrictions on the recipients' exercise of the rights granted herein.
You are not responsible for enforcing compliance by third parties to
this License.

  7. If, as a consequence of a court judgment or allegation of patent
infringement or for any other reason (not limited to patent issues),
conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License.  If you cannot
distribute so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you
may not distribute the Program at all.  For example, if a patent
license would not permit royalty-free redistribution of the Program by
all those who receive copies directly or indirectly through you, then
the only way you could satisfy both it and this License would be to
refrain entirely from distribution of the Program.

If any portion of this section is held invalid or unenforceable under
any particular circumstance, the balance of the section is intended to
apply and the section as a whole is intended to apply in other
circumstances.

It is not the purpose of this section to induce you to infringe any
patents or other property right claims or to contest validity of any
such claims; this section has the sole purpose of protecting the
integrity of the free software distribution system, which is
implemented by public license practices.  Many people have made
generous contributions to the wide range of software distributed
through that system in reliance on consistent application of that
system; it is up to the author/donor to decide if he or she is willing
to distribute software through any other system and a licensee cannot
impose that choice.

This section is intended to make thoroughly clear what is believed to
be a consequence of the rest of this License.

  8. If the distribution and/or use of the Program is restricted in
certain countries either by patents or by copyrighted interfaces, the
original copyright holder who places the Program under this License
may add an explicit geographical distribution limitation excluding
those countries, so that distribution is permitted only in or among
countries not thus excluded.  In such case, this License incorporates
the limitation as if written in the body of this License.

  9. The Free Software Foundation may publish revised and/or new versions
of the General Public License from time to time.  Such new versions will
be similar in spirit to the present version, but may differ in detail to
address new problems or concerns.

Each version is given a distinguishing version number.  If the Program
specifies a version number of this License which applies to it and "any
later version", you have the option of following the terms and conditions
either of that version or of any later version published by the Free
Software Foundation.  If the Program does not specify a version number of
this License, you may choose any version ever published by the Free Software
Foundation.

  10. If you wish to incorporate parts of the Program into other free
programs whose distribution conditions are different, write to the author
to ask for permission.  For software which is copyrighted by the Free
Software Foundation, write to the Free Software Foundation; we sometimes
make exceptions for this.  Our decision will be guided by the two goals
of preserving the free status of all derivatives of our free software and
of promoting the sharing and reuse of software generally.

			    NO WARRANTY

  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS
TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE
PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
REPAIR OR CORRECTION.

  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
POSSIBILITY OF SUCH DAMAGES.

		     END OF TERMS AND CONDITIONS

	    How to Apply These Terms to Your New Programs

  If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these terms.

  To do so, attach the following notices to the program.  It is safest
to attach them to the start of each source file to most effectively
convey the exclusion of warranty; and each file should have at least
the "copyright" line and a pointer to where the full notice is found.

    <one line to give the program's name and a brief idea of what it does.>
    Copyright (C) <year>  <name of author>

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA


Also add information on how to contact you by electronic and paper mail.

If the program is interactive, make it output a short notice like this
when it starts in an interactive mode:

    Gnomovision version 69, Copyright (C) year  name of author
    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
    This is free software, and you are welcome to redistribute it
    under certain conditions; type `show c' for details.

The hypothetical commands `show w' and `show c' should show the appropriate
parts of the General Public License.  Of course, the commands you use may
be called something other than `show w' and `show c'; they could even be
mouse-clicks or menu items--whatever suits your program.

You should also get your employer (if you work as a programmer) or your
school, if any, to sign a "copyright disclaimer" for the program, if
necessary.  Here is a sample; alter the names:

  Yoyodyne, Inc., hereby disclaims all copyright interest in the program
  `Gnomovision' (which makes passes at compilers) written by James Hacker.

  <signature of Ty Coon>, 1 April 1989
  Ty Coon, President of Vice

This General Public License does not permit incorporating your program into
proprietary programs.  If your program is a subroutine library, you may
consider it more useful to permit linking proprietary applications with the
library.  If this is what you want to do, use the GNU Library General
Public License instead of this License.


GNU Free Documentation License
******************************

                        Version 1.1, March 2000
     Copyright (C) 2000 Free Software Foundation, Inc.
     51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
     
     Everyone is permitted to copy and distribute verbatim copies
     of this license document, but changing it is not allowed.

  0. PREAMBLE

     The purpose of this License is to make a manual, textbook, or other
     written document "free" in the sense of freedom: to assure everyone
     the effective freedom to copy and redistribute it, with or without
     modifying it, either commercially or noncommercially.  Secondarily,
     this License preserves for the author and publisher a way to get
     credit for their work, while not being considered responsible for
     modifications made by others.

     This License is a kind of "copyleft", which means that derivative
     works of the document must themselves be free in the same sense.
     It complements the GNU General Public License, which is a copyleft
     license designed for free software.

     We have designed this License in order to use it for manuals for
     free software, because free software needs free documentation: a
     free program should come with manuals providing the same freedoms
     that the software does.  But this License is not limited to
     software manuals; it can be used for any textual work, regardless
     of subject matter or whether it is published as a printed book.
     We recommend this License principally for works whose purpose is
     instruction or reference.

  1. APPLICABILITY AND DEFINITIONS

     This License applies to any manual or other work that contains a
     notice placed by the copyright holder saying it can be distributed
     under the terms of this License.  The "Document", below, refers to
     any such manual or work.  Any member of the public is a licensee,
     and is addressed as "you".

     A "Modified Version" of the Document means any work containing the
     Document or a portion of it, either copied verbatim, or with
     modifications and/or translated into another language.

     A "Secondary Section" is a named appendix or a front-matter
     section of the Document that deals exclusively with the
     relationship of the publishers or authors of the Document to the
     Document's overall subject (or to related matters) and contains
     nothing that could fall directly within that overall subject.
     (For example, if the Document is in part a textbook of
     mathematics, a Secondary Section may not explain any mathematics.)
     The relationship could be a matter of historical connection with
     the subject or with related matters, or of legal, commercial,
     philosophical, ethical or political position regarding them.

     The "Invariant Sections" are certain Secondary Sections whose
     titles are designated, as being those of Invariant Sections, in
     the notice that says that the Document is released under this
     License.

     The "Cover Texts" are certain short passages of text that are
     listed, as Front-Cover Texts or Back-Cover Texts, in the notice
     that says that the Document is released under this License.

     A "Transparent" copy of the Document means a machine-readable copy,
     represented in a format whose specification is available to the
     general public, whose contents can be viewed and edited directly
     and straightforwardly with generic text editors or (for images
     composed of pixels) generic paint programs or (for drawings) some
     widely available drawing editor, and that is suitable for input to
     text formatters or for automatic translation to a variety of
     formats suitable for input to text formatters.  A copy made in an
     otherwise Transparent file format whose markup has been designed
     to thwart or discourage subsequent modification by readers is not
     Transparent.  A copy that is not "Transparent" is called "Opaque".

     Examples of suitable formats for Transparent copies include plain
     ASCII without markup, Texinfo input format, LaTeX input format,
     SGML or XML using a publicly available DTD, and
     standard-conforming simple HTML designed for human modification.
     Opaque formats include PostScript, PDF, proprietary formats that
     can be read and edited only by proprietary word processors, SGML
     or XML for which the DTD and/or processing tools are not generally
     available, and the machine-generated HTML produced by some word
     processors for output purposes only.

     The "Title Page" means, for a printed book, the title page itself,
     plus such following pages as are needed to hold, legibly, the
     material this License requires to appear in the title page.  For
     works in formats which do not have any title page as such, "Title
     Page" means the text near the most prominent appearance of the
     work's title, preceding the beginning of the body of the text.

  2. VERBATIM COPYING

     You may copy and distribute the Document in any medium, either
     commercially or noncommercially, provided that this License, the
     copyright notices, and the license notice saying this License
     applies to the Document are reproduced in all copies, and that you
     add no other conditions whatsoever to those of this License.  You
     may not use technical measures to obstruct or control the reading
     or further copying of the copies you make or distribute.  However,
     you may accept compensation in exchange for copies.  If you
     distribute a large enough number of copies you must also follow
     the conditions in section 3.

     You may also lend copies, under the same conditions stated above,
     and you may publicly display copies.

  3. COPYING IN QUANTITY

     If you publish printed copies of the Document numbering more than
     100, and the Document's license notice requires Cover Texts, you
     must enclose the copies in covers that carry, clearly and legibly,
     all these Cover Texts: Front-Cover Texts on the front cover, and
     Back-Cover Texts on the back cover.  Both covers must also clearly
     and legibly identify you as the publisher of these copies.  The
     front cover must present the full title with all words of the
     title equally prominent and visible.  You may add other material
     on the covers in addition.  Copying with changes limited to the
     covers, as long as they preserve the title of the Document and
     satisfy these conditions, can be treated as verbatim copying in
     other respects.

     If the required texts for either cover are too voluminous to fit
     legibly, you should put the first ones listed (as many as fit
     reasonably) on the actual cover, and continue the rest onto
     adjacent pages.

     If you publish or distribute Opaque copies of the Document
     numbering more than 100, you must either include a
     machine-readable Transparent copy along with each Opaque copy, or
     state in or with each Opaque copy a publicly-accessible
     computer-network location containing a complete Transparent copy
     of the Document, free of added material, which the general
     network-using public has access to download anonymously at no
     charge using public-standard network protocols.  If you use the
     latter option, you must take reasonably prudent steps, when you
     begin distribution of Opaque copies in quantity, to ensure that
     this Transparent copy will remain thus accessible at the stated
     location until at least one year after the last time you
     distribute an Opaque copy (directly or through your agents or
     retailers) of that edition to the public.

     It is requested, but not required, that you contact the authors of
     the Document well before redistributing any large number of
     copies, to give them a chance to provide you with an updated
     version of the Document.

  4. MODIFICATIONS

     You may copy and distribute a Modified Version of the Document
     under the conditions of sections 2 and 3 above, provided that you
     release the Modified Version under precisely this License, with
     the Modified Version filling the role of the Document, thus
     licensing distribution and modification of the Modified Version to
     whoever possesses a copy of it.  In addition, you must do these
     things in the Modified Version:

       A. Use in the Title Page (and on the covers, if any) a title
          distinct from that of the Document, and from those of
          previous versions (which should, if there were any, be listed
          in the History section of the Document).  You may use the
          same title as a previous version if the original publisher of
          that version gives permission.

       B. List on the Title Page, as authors, one or more persons or
          entities responsible for authorship of the modifications in
          the Modified Version, together with at least five of the
          principal authors of the Document (all of its principal
          authors, if it has less than five).

       C. State on the Title page the name of the publisher of the
          Modified Version, as the publisher.

       D. Preserve all the copyright notices of the Document.

       E. Add an appropriate copyright notice for your modifications
          adjacent to the other copyright notices.

       F. Include, immediately after the copyright notices, a license
          notice giving the public permission to use the Modified
          Version under the terms of this License, in the form shown in
          the Addendum below.

       G. Preserve in that license notice the full lists of Invariant
          Sections and required Cover Texts given in the Document's
          license notice.

       H. Include an unaltered copy of this License.

       I. Preserve the section entitled "History", and its title, and
          add to it an item stating at least the title, year, new
          authors, and publisher of the Modified Version as given on
          the Title Page.  If there is no section entitled "History" in
          the Document, create one stating the title, year, authors,
          and publisher of the Document as given on its Title Page,
          then add an item describing the Modified Version as stated in
          the previous sentence.

       J. Preserve the network location, if any, given in the Document
          for public access to a Transparent copy of the Document, and
          likewise the network locations given in the Document for
          previous versions it was based on.  These may be placed in
          the "History" section.  You may omit a network location for a
          work that was published at least four years before the
          Document itself, or if the original publisher of the version
          it refers to gives permission.

       K. In any section entitled "Acknowledgments" or "Dedications",
          preserve the section's title, and preserve in the section all
          the substance and tone of each of the contributor
          acknowledgments and/or dedications given therein.

       L. Preserve all the Invariant Sections of the Document,
          unaltered in their text and in their titles.  Section numbers
          or the equivalent are not considered part of the section
          titles.

       M. Delete any section entitled "Endorsements".  Such a section
          may not be included in the Modified Version.

       N. Do not retitle any existing section as "Endorsements" or to
          conflict in title with any Invariant Section.

     If the Modified Version includes new front-matter sections or
     appendices that qualify as Secondary Sections and contain no
     material copied from the Document, you may at your option
     designate some or all of these sections as invariant.  To do this,
     add their titles to the list of Invariant Sections in the Modified
     Version's license notice.  These titles must be distinct from any
     other section titles.

     You may add a section entitled "Endorsements", provided it contains
     nothing but endorsements of your Modified Version by various
     parties--for example, statements of peer review or that the text
     has been approved by an organization as the authoritative
     definition of a standard.

     You may add a passage of up to five words as a Front-Cover Text,
     and a passage of up to 25 words as a Back-Cover Text, to the end
     of the list of Cover Texts in the Modified Version.  Only one
     passage of Front-Cover Text and one of Back-Cover Text may be
     added by (or through arrangements made by) any one entity.  If the
     Document already includes a cover text for the same cover,
     previously added by you or by arrangement made by the same entity
     you are acting on behalf of, you may not add another; but you may
     replace the old one, on explicit permission from the previous
     publisher that added the old one.

     The author(s) and publisher(s) of the Document do not by this
     License give permission to use their names for publicity for or to
     assert or imply endorsement of any Modified Version.

  5. COMBINING DOCUMENTS

     You may combine the Document with other documents released under
     this License, under the terms defined in section 4 above for
     modified versions, provided that you include in the combination
     all of the Invariant Sections of all of the original documents,
     unmodified, and list them all as Invariant Sections of your
     combined work in its license notice.

     The combined work need only contain one copy of this License, and
     multiple identical Invariant Sections may be replaced with a single
     copy.  If there are multiple Invariant Sections with the same name
     but different contents, make the title of each such section unique
     by adding at the end of it, in parentheses, the name of the
     original author or publisher of that section if known, or else a
     unique number.  Make the same adjustment to the section titles in
     the list of Invariant Sections in the license notice of the
     combined work.

     In the combination, you must combine any sections entitled
     "History" in the various original documents, forming one section
     entitled "History"; likewise combine any sections entitled
     "Acknowledgments", and any sections entitled "Dedications".  You
     must delete all sections entitled "Endorsements."

  6. COLLECTIONS OF DOCUMENTS

     You may make a collection consisting of the Document and other
     documents released under this License, and replace the individual
     copies of this License in the various documents with a single copy
     that is included in the collection, provided that you follow the
     rules of this License for verbatim copying of each of the
     documents in all other respects.

     You may extract a single document from such a collection, and
     distribute it individually under this License, provided you insert
     a copy of this License into the extracted document, and follow
     this License in all other respects regarding verbatim copying of
     that document.

  7. AGGREGATION WITH INDEPENDENT WORKS

     A compilation of the Document or its derivatives with other
     separate and independent documents or works, in or on a volume of
     a storage or distribution medium, does not as a whole count as a
     Modified Version of the Document, provided no compilation
     copyright is claimed for the compilation.  Such a compilation is
     called an "aggregate", and this License does not apply to the
     other self-contained works thus compiled with the Document, on
     account of their being thus compiled, if they are not themselves
     derivative works of the Document.

     If the Cover Text requirement of section 3 is applicable to these
     copies of the Document, then if the Document is less than one
     quarter of the entire aggregate, the Document's Cover Texts may be
     placed on covers that surround only the Document within the
     aggregate.  Otherwise they must appear on covers around the whole
     aggregate.

  8. TRANSLATION

     Translation is considered a kind of modification, so you may
     distribute translations of the Document under the terms of section
     4.  Replacing Invariant Sections with translations requires special
     permission from their copyright holders, but you may include
     translations of some or all Invariant Sections in addition to the
     original versions of these Invariant Sections.  You may include a
     translation of this License provided that you also include the
     original English version of this License.  In case of a
     disagreement between the translation and the original English
     version of this License, the original English version will prevail.

  9. TERMINATION

     You may not copy, modify, sublicense, or distribute the Document
     except as expressly provided for under this License.  Any other
     attempt to copy, modify, sublicense or distribute the Document is
     void, and will automatically terminate your rights under this
     License.  However, parties who have received copies, or rights,
     from you under this License will not have their licenses
     terminated so long as such parties remain in full compliance.

 10. FUTURE REVISIONS OF THIS LICENSE

     The Free Software Foundation may publish new, revised versions of
     the GNU Free Documentation License from time to time.  Such new
     versions will be similar in spirit to the present version, but may
     differ in detail to address new problems or concerns.  See
     `http://www.gnu.org/copyleft/'.

     Each version of the License is given a distinguishing version
     number.  If the Document specifies that a particular numbered
     version of this License "or any later version" applies to it, you
     have the option of following the terms and conditions either of
     that specified version or of any later version that has been
     published (not as a draft) by the Free Software Foundation.  If
     the Document does not specify a version number of this License,
     you may choose any version ever published (not as a draft) by the
     Free Software Foundation.

ADDENDUM: How to use this License for your documents
----------------------------------------------------

  To use this License in a document you have written, include a copy of
the License in the document and put the following copyright and license
notices just after the title page:

       Copyright (C)  YEAR  YOUR NAME.
       Permission is granted to copy, distribute and/or modify this document
       under the terms of the GNU Free Documentation License, Version 1.1
       or any later version published by the Free Software Foundation;
       with the Invariant Sections being LIST THEIR TITLES, with the
       Front-Cover Texts being LIST, and with the Back-Cover Texts being LIST.
       A copy of the license is included in the section entitled ``GNU
       Free Documentation License''.

  If you have no Invariant Sections, write "with no Invariant Sections"
instead of saying which ones are invariant.  If you have no Front-Cover
Texts, write "no Front-Cover Texts" instead of "Front-Cover Texts being
LIST"; likewise for Back-Cover Texts.

  If your document contains nontrivial examples of program code, we
recommend releasing these examples in parallel under your choice of
free software license, such as the GNU General Public License, to
permit their use in free software.









Added stml2/INSTALL version [25d174366c].



























1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

These are rough installation instructions. Please contact me at matt@kiatoa.com
if you have trouble installing.

1. Copy install.cfg.template to install.cfg and modify appropriately

2. Copy stml.config.template to your cgi dir as .stml.config and modify appropriately
    - choose your db

3. Copy requirements.scm.template to requirements.scm and modify as needed
    - choose your db (must match what you choose in 2. above)

If on 64 bit and you get error in compiling try fPIC:

CSC_OPTIONS='-C "-fPIC"' make

run 

> make 

or 

> CSC_OPTIONS='-C "-fPIC"' make









Added stml2/Makefile version [0ba4186b5a].




























































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

# Copyright 2007-2008, 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.
#
# Following needed on bluehost (maybe on all 64bit?)
#
# CSC_OPTIONS='-C "-fPIC"' make
#
include install.cfg

SRCFILES    = stml2.scm misc-stml.scm session.scm sqltbl.scm formdat.scm setup.scm keystore.scm html-filter.scm cookie.scm 
MODULEFILES = $(wildcard modules/*/*-mod.scm)
SOFILES     = $(MODULEFILES:%.scm=%.so)
CFILES      = $(MODULEFILES:%.scm=%.c)
OFILES      = $(SRCFILES:%.scm=%.o)
TARGFILES   = $(notdir $(SOFILES))
MODULES     = $(addprefix $(TARGDIR)/modules/,$(TARGFILES))

install : $(TARGDIR)/stmlrun $(LOGDIR) $(MODULES)
	chicken-install

all : $(SOFILES)

# stmlrun : stmlrun.scm formdat.scm  misc-stml.scm  session.scm stml.scm \
#           setup.scm html-filter.scm requirements.scm keystore.scm \
#           cookie.scm sqltbl.scm
# 	csc stmlrun.scm

$(TARGDIR)/stmlrun : stmlrun stml2.so
	echo "NOTE: CSC_OPTIONS='-C \"-fPIC\"' make"
	install stmlrun $(TARGDIR)
	chmod a+rx $(TARGDIR)/stmlrun

$(TARGDIR)/modules :
	mkdir -p $(TARGDIR)/modules

$(MODULES) : $(SOFILES) $(TARGDIR)/modules
	cp $< $@

stmlrun : $(OFILES) stmlrun.scm requirements.scm stmlcommon.scm
	csc $(CSCOPTS) $(OFILES) stmlrun.scm -o stmlrun

stml.so : stmlmodule.so
	cp stmlmodule.so stml.so

stmlmodule.so : $(OFILES) stmlmodule.scm requirements.scm stmlcommon.scm
	csc $(CSCOPTS) $(OFILES) -s stmlmodule.scm

# logging currently relies on this
#
$(LOGDIR) :
	mkdir -p $(LOGDIR)
	chmod a+rwx $(LOGDIR)

test: kiatoa.db cookie.so
	echo '(exit)'| csi -q  ./tests/test.scm 

# modules
#
%.so : %.scm
	csc $(CSCOPTS) -I modules/* -s $<

%.o : %.scm
	csc $(CSCOPTS) -c $<

# Cookie is a special case for now. Make a loadable so for test
# Complile it in by include (see dependencies above).
cookie.so : cookie.scm
	csc i$(CSCOPTS) -s cookie.scm

clean :
	rm -f doc/*~ modules/*/*.so *.import.scm *.import.so *.o *.so *~

# $(CFILES): build/%.c: ../scm/%.scm ../scm/macros.scm
# 	chicken $< -output-file $@
# 
# 
# $(OFILES): src/%.o: src/%.c
# 	gcc -c $< `chicken-config -cflags` -o $@
# 
# $(src_code): %: src/%.o src/laedlib.o src/layobj.o
# 	gcc src/$*.o src/laedlib.o src/layobj.o -o $* `chicken-config -libs`
# 








Added stml2/README version [a1795f6205].





1

+

This is the stml, scheme based cgi application framework. 








Added stml2/TODO version [14eed9b843].


























1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

1. Documentation. 
      multiple apps in same cgi dir
      compilation of models for speed and code protection
      tricks
2. Hierarchial pages. Currently pages can be hierarchial but the control.scm 
   doesn't get called at the right time. 
3. For sqlite3 usage put session into own db?
4. A mechanism for sharing variables better between control and view
   would be good.
   Perhaps:
     (let ()
       (load control)
       (load view))
5. Change all the "included" files to be seperately compiled units
   and adj. makefile accordingly. This would speed up compilation
   when changes are isolated to one or two files.
6. The dbi interface needs a simple config mecanism alternative to
   the current list of pairs which is hard to use on the fly. 
   Something like the perl:
     "dbi:host:port:user:password"

I'm sure there is more ...








Added stml2/cookie.scm version [d78a525a3a].












































































































































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
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
227
228
229
230
231
232
233
234
235
236
237
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

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;;;
;;; cookie.scm - parse and construct http state information
;;;  
;;;   Copyright (c) 2000-2003 Shiro Kawai, All rights reserved.
;;;   
;;;   Redistribution and use in source and binary forms, with or without
;;;   modification, are permitted provided that the following conditions
;;;   are met:
;;;   
;;;   1. Redistributions of source code must retain the above copyright
;;;      notice, this list of conditions and the following disclaimer.
;;;  
;;;   2. Redistributions in binary form must reproduce the above copyright
;;;      notice, this list of conditions and the following disclaimer in the
;;;      documentation and/or other materials provided with the distribution.
;;;  
;;;   3. Neither the name of the authors nor the names of its contributors
;;;      may be used to endorse or promote products derived from this
;;;      software without specific prior written permission.
;;;  
;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;  
;;;  Ported to Chicken by Reed Sheridan
;;;

;; Parser and constructor of http "Cookies" defined in
;; RFC 2965 HTTP state managemnet mechanism
;;   <ftp://ftp.isi.edu/in-notes/rfc2965.txt>
;; See also
;; RFC 2964 Use of HTTP state management
;;   <ftp://ftp.isi.edu/in-notes/rfc2964.txt>
;; The parser also supports the old Netscape spec
;;   <http://www.netscape.com/newsref/std/cookie_spec.html>

;; (declare (unit cookie))

(module cookie
    *

(import chicken scheme data-structures extras srfi-13 ports 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>
;; <#
;; 
;; (define fmt-time
;;   (foreign-lambda* c-string ((long secs_since_epoch))
;;     "static char buf[256];"
;;     "time_t t = (time_t) secs_since_epoch;"
;;     "strftime(buf, sizeof(buf), \"%a, %d-%b-%Y %H:%M:%S GMT\", gmtime(&t));"
;;     "return(buf);"))


(define (fmt-time seconds)
   (time->string (seconds->utc-time seconds) "%D"))

 ;; utility fn.  breaks  ``attr=value;attr=value ... '' into alist.
 ;; version is a cookie version.  if version>0, we allow comma as the
 ;; delimiter as well as semicolon.
 (define (parse-av-pairs input version)
   (define attr-regexp
     (if (= version 0)
         (regexp "\\s*([\\w$_-]+)\\s*([=\\;]\\s*)?")
         (regexp "\\s*([\\w$_-]+)\\s*([=\\;,]\\s*)?")))
   (define attr-delim
     (if (= version 0) #\; (char-set #\, #\\ #\;)))
   
   (define (read-attr input r)
     (cond ((string-null? input) (reverse! r))
           ((string-search attr-regexp input)
            => (lambda (m)
                 (if (and-let* ((delimiter (third m))) ;;is an attr_value pai
 		      (string-prefix? "=" delimiter))
                     (let ((attr (second m))
                           (rest (string-search-after attr-regexp input)))
                       (if (string-prefix? "\"" rest)
                           (read-token-quoted attr (string-drop rest 1) r)
                           (read-token attr rest r)))
                     (read-attr (string-search-after attr-regexp input) ;; Skip ahead if broken input?
                                (alist-cons (second m) #f r)))))
           (else
            ;; the input is broken; for now, we ignore the rest.
            (reverse! r))))
   (define (read-token attr input r)
     (cond ((string-index input attr-delim)
            => (lambda (i)
                 (read-attr (string-drop input (+ i 1))
                            (alist-cons attr
 				       (string-trim-right (string-take input i))
 				       r))))
           (else
            (reverse! (alist-cons attr (string-trim-right input) r)))))
   (define (read-token-quoted attr input r)
     (let loop ((input input)
                (partial '()))
       (cond ((string-index input (char-set #\\ #\"))
              => (lambda (i)
                   (let ((c (string-ref input i)))
                     (if (char=? c #\\)
                         (if (< (string-length input) (+ i 1))
                             (error-unterminated attr)
                             (loop (string-drop input (+ i 2))
                                   (cons* (string (string-ref input (+ i 1)))
                                          (string-take input i)
                                          partial)))
                         (read-attr (string-drop input (+ i 1))
                                    (alist-cons attr
 					       (string-concatenate-reverse
 						(cons (string-take input i)
 						      partial))
 					       r))))))
             (else (error-unterminated attr)))))
   (define (error-unterminated attr)
     (error "Unterminated quoted value given for attribute" attr))
 
   (read-attr input '()))
 
 ;; Parses the header value of "Cookie" request header.
 ;; If cookie version is known by "Cookie2" request header, it should
 ;; be passed to version (as integer).  Otherwise, it figures out
 ;; the cookie version from input.
 ;;
 ;; Returns the following format.
 ;;   ((<name> <value> [:path <path>] [:domain <domain>] [:port <port>])
 ;;    ...)
 
 (define (parse-cookie-string input #!optional version)
   (let ((ver (cond ((integer? version) version)
                    ((string-search "^\\s*\\$Version\\s*=\\s*(\\d+)" input)
                     => (lambda (m)
                          (string->number (cadr m))))
                    (else 0))))
     (let loop ((av-pairs (parse-av-pairs input ver))
                (r '())
                (current '()))
       (cond ((null? av-pairs)
              (if (null? current)
                  (reverse r)
                  (reverse (cons (reverse current) r))))
             ((string-ci=? "$path" (caar av-pairs))
              (loop (cdr av-pairs) r (cons* (cdar av-pairs) path: current)))
             ((string-ci=? "$domain" (caar av-pairs))
              (loop (cdr av-pairs) r (cons* (cdar av-pairs) domain: current)))
             ((string-ci=? "$port" (caar av-pairs))
              (loop (cdr av-pairs) r (cons* (cdar av-pairs) port: current)))
             (else
              (if (null? current)
                  (loop (cdr av-pairs) r (list (cdar av-pairs) (caar av-pairs)))
                  (loop (cdr av-pairs)
                        (cons (reverse current) r)
                        (list (cdar av-pairs) (caar av-pairs)))))))))
 
 ;; Construct a cookie string suitable for Set-Cookie or Set-Cookie2 header.
 ;; specs is the following format.
 ;;
 ;;   ((<name> <value> [:comment <comment>] [:comment-url <comment-url>]
 ;;                    [:discard <bool>] [:domain <domain>]
 ;;                    [:max-age <age>] [:path <value>] [:port <port-list>]
 ;;                    [:secure <bool>] [:version <version>] [:expires <date>]
 ;;    ) ...)
 ;;
 ;; Returns a list of cookie strings for each <name>=<value> pair.  In the
 ;; ``new cookie'' implementation, you can join them by comma and send it
 ;; at once with Set-cookie2 header.  For the old netscape protocol, you
 ;; must send each of them by Set-cookie header.
 
 
 (define (construct-cookie-string specs #!optional (version 1))
   (map (lambda (spec) (construct-cookie-string-1 spec version))
        specs))
 
 (define (construct-cookie-string-1 spec ver)
   (when (< (length spec) 2)
     (error "bad cookie spec: at least <name> and <value> required" spec))
   (let ((name (car spec))
         (value (cadr spec)))
     (let loop ((attr (cddr spec))
                (r    (list (if value
                                (string-append name "="
                                               (quote-if-needed value))
                                name))))
       (define (next s) (loop (cddr attr) (cons s r)))
       (define (ignore) (loop (cddr attr) r))
       (cond
        ((null? attr) (string-join (reverse r) ";"))
        ((null? (cdr attr))
         (error (conc "bad cookie spec: attribute " (car attr) " requires value" )))
        ((eqv? comment: (car attr))
         (if (> ver 0)
 	    (next (string-append "Comment=" (quote-if-needed (cadr attr))))
             (ignore)))
        ((eqv? comment-url: (car attr))
         (if (> ver 0)
             (next (string-append "CommentURL=" (quote-value (cadr attr))))
             (ignore)))
        ((eqv? discard: (car attr))
         (if (and (> ver 0) (cadr attr)) (next "Discard") (ignore)))
        ((eqv? domain: (car attr))
         (next (string-append "Domain=" (cadr attr))))
        ((eqv? max-age: (car attr))
         (if (> ver 0)
             (next (sprintf "Max-Age=~a" (cadr attr)))
             (ignore)))
        ((eqv? path: (car attr))
         (next (string-append "Path=" (quote-if-needed (cadr attr)))))
        ((eqv? port: (car attr))
         (if (> ver 0)
             (next (string-append "Port=" (quote-value (cadr attr))))
             (ignore)))
        ((eqv? secure: (car attr))
         (if (cadr attr) (next "Secure") (ignore)))
        ((eqv? version: (car attr))
         (if (> ver 0)
             (next (sprintf "Version=~a" (cadr attr)))
             (ignore)))
        ((eqv? expires: (car attr))
         (if (> ver 0)
             (ignore)
             (next (make-expires-attr (cadr attr)))))
        (else (error "Unknown cookie attribute" (car attr))))
       ))
   )
 
 
 ;; (define (quote-value value)
 ;;   (string-append "\"" (regexp-replace-all #/\"|\\/ value "\\\\\\0") "\""))
 
 (define (quote-value value)
   (string-append "\"" (string-substitute* value '(("\\\"" . "\\\"") ("\\\\" . "\\\\"))) "\""))
 
 (define quote-if-needed
   (let ((rx (regexp "[\\\",;\\\\ \\t\\n]")))
     (lambda (value)
       (if (string-search rx value)
 	  (quote-value value)
 	  value))))
 
 (define (make-expires-attr time)
   (sprintf "Expires=~a"
 	   (if (number? time)
 	       (fmt-time time)
 	       time)))
 
 ;;;; Added support functions from my utils, split this out
 
 (define (string-search-after r s #!optional (start 0))
   (and-let* ((match-indices (string-search-positions r s start))
 	     (right-match (second (first match-indices))))
     (substring s right-match)))
)








Added stml2/doc/Makefile version [93337f215f].











1
2
3
4
5
6
7

+
+
+
+
+
+
+

all : manual.pdf web-page.html

manual.pdf : manual.txt
	a2x -a toc -f pdf manual.txt
	# asciidoc -a toc plan.txt
	a2x -f chunked -a toc manual.txt









Added stml2/doc/howto.txt version [2ccf521fee].





















































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

Gotchas!
=======

All items for a page *must* be part of a list!
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

   OK:     (list (function1 param1)(function2 param2))
   NOT OK: (begin (function1 param1)(function2 param2))


Various components
~~~~~~~~~~~~~~~~~~

The URL:

http://the.domain.com/pagename/p1/p2/p3?param1=value1

(s:get-page-params) => '("p1" "p2")

(s:get-param 'param1) => "value1"
(s:get-param 'param1 'number) => number or #f 

NOTE: it is often practical to use the generic (s:get-inp ...) which
      will first look for the POST input variable and then fall back
      to the GET param. This allows one to switch back and forth
      between GET and POST during development without changing the code.

(s:get-inp 'param1)  ;; trys to find input by name of param1, followed by trying get-param

Create a link.
~~~~~~~~~~~~~~

(s:a name 'href 
    (s:link-to "pagename/blah" ""))

Call current page with new param
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

In view.scm:

 (s:center "[" (s:a 'href (s:link-to "polls"
                           'id
                            (begin
                              (poll:poll 'fill-polls)
                              (poll:poll 'get-next-poll)))
                          "Go to the next poll")  "]")

In control.scm:

(let ((poll-id (s:get-param 'id)))
 ;; do stuff based on poll-id


Call an action on a specific page
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

 (s:a 'href (s:link-to "polls" 'id (poll:poll 'get 'id) 
			       'action "poll.edit")
            "Suggest changes to this poll")

 NOT TRUE! This calls fuction poll.edit (should be in control.scm). Parameter set is 'id to a poll num.


A complex link example
~~~~~~~~~~~~~~~~~~~~~~

(s:a "Reply" 'href (s:link-to (s:current-page) 
	           'action "discussion.reply" ;; <page>.<action>
	           'reply_to (number->string (hash-table-ref row 'posts.id)) 
	           'id (s:get "discussion.parent_object_id")) "reply")

;; use (s:get-param to get the 'id, or 'reply_to values


Get and set a session var
~~~~~~~~~~~~~~~~~~~~~~~~~

(s:session-var-get "keyname")
(s:session-var-get "keyname" 'number) 
(s:session-var-set! "keyname" "value")

5.1 Page local vars

(s:set! key val)
(s:get key)


make a selection drop down
~~~~~~~~~~~~~~~~~~~~~~~~~~

;; items is a hierarchial alist
;; ( (label1 value1 dispval1 #t) ;; <== this one is selected
;;   (label2 (label3 value2 dispval2)
;;           (label4 value3 dispval3)))

In view.scm: 

;;                                   Label   Value visible-str selected
(s:select '(("World" 0)("Country" 1)("State" 2     "The state" #t       )("Town/City" 3)) 'name 'scope)

Visible str will be shown if provided. Selected will set that entry to pre-selected.

To select a specific entry:

(s:select '(("World" 0 "world" #f)("Country" 1 "country" #t)("State" 2 "state" #f)("Town/City" 3 "town" #f)) 'name 'scope)

In control.scm:

(let ((scope     (s:get-input 'scope))
      (scope-num (s:get-input 'scope 'number))) ;; 'number, 'raw or 'escaped
  ....

The optional fourth entry sets that item as selected if true

Simple error reporting
~~~~~~~~~~~~~~~~~~~~~~

In control.scm:
(s:set-err "You must provide an email address")

In view.scm:
(s:get-err s:err-font)

Or:
(s:get-err (lambda (x)(s:err-font x (s:br))))


Sharing data between pages
~~~~~~~~~~~~~~~~~~~~~~~~~~

NOTE: This data is *not* preserved between cgi calls.

;; In first page called
(s:shared-set! "somekey" somevalue)

;; In a page called later
(let ((dat (s:shared-get "somekey")))
  ( .... ))


Misc useful stuff
~~~~~~~~~~~~~~~~~

  i. Lazy/safe string->number 

(s:any->number val)

  ii. Random string

(session:make-rand-string len)

 iii. string to number for pgint
 
(s:any->pgint val)


Forms and input
~~~~~~~~~~~~~~~

(s:form 'action "login.login" 'method "post"
   (s:input-preserve 'type "text" 'name "email-address" 'size "16" 'maxlength "30")
   (s:input 'type "submit"   'name "form-name" 'value "login"))

(s:get-input 'email-address)

To preserve the input simply do a set of the value on the 'name field:
(s:set! "email-address" "matt@kiatoa.com")

Radio buttons:

	(s:div 'class "col_3"
		       (s:input 'type "radio" 'id "group-type1" 'name "group-type" 'value "private" 'checked "checked")
		       (s:label 'for "group-type1" 'class "inline" "Private")
		       (s:input 'type "radio" 'id "group-type2" 'name "group-type" 'value "public")
		       (s:label 'for "group-type2" 'class "inline" "Public"))

       (s:get-input 'group-type) ==> returns private or public depending on which is selected.








Added stml2/doc/manual.txt version [ae796565bb].




























































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

STML User Manual
================
Matt Welland <matt@kiatoa.com>
v1.0, 2012-6

NOT DONE YET! :( sorry.

:numbered!:
[abstract]
Example Abstract
----------------

Yada about stml

:numbered:

User Data Specification
-----------------------

.User Data
[width="100%",options="header",cols="<s,2m,2e,2e,2e",frame="topbot"]
|==============================
| Field            | Field Template    |Short form| Example                              | Description
| Likes            | :likes            |:l        | :likes rock, jazz, blues             | List of things liked, used to narrow down music liked etc.
|==============================

.Example stuff
-----------------------------
stuff eh
-----------------------------

// -----------------------

<<<<<<<<<<<<<<<<<

Plan
----

Today
~~~~~

. Nothing scheduled

Done Stuff
~~~~~~~~~~

Phase 3
~~~~~~~

. Error printing with debug levels
. Complete the manual
. Get working with Chromium, test with Internet Explorer and other browsers

Notes
-----









Added stml2/doc/stml-snapshot.png version [e6cb8d257e].

cannot compute difference between binary files




Added stml2/example/Makefile version [d224d59dca].






























1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

# Copyright 2007-2008, 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.

# Uncomment and fix path if you want your models to be compiled
#
MODELS := $(wildcard models/*scm)
SOFILES := $(patsubst %.scm,%.so,$(MODELS))


# all : $(SOFILES)

# If you want compiled models uncomment the following
#
# $(SOFILES) : %.so: %.scm
#	csc -s $<

test: # $(SOFILES)
	echo '(exit)'| csi -q  ./tests/test.scm 

# cgi-util proplist cgi-util cookie








Added stml2/example/POLICY version [da39a3ee5e].








Added stml2/example/README version [a8907c6b3f].







1
2
3

+
+
+

This is an (unfinished) example application. 

To see it live go to: www.approvalvote.org








Added stml2/example/TODO version [71853c6197].






1
2

+
+











Added stml2/example/db/db-tweaks.sql version [b1c54e147f].
















































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

>-- create table polls(id serial not null,poll_type text,title text,description text,poll_state text);
-- create table poll_categories(id serial not null,poll_id integer,description text);
-- create table poll_votes(id serial not null,period integer,poll_type text,poll_category text,voter_group integer, votes integer);

-- create table vote_items (id serial primary key,type integer,item_id integer,item_level text,town_votes integer,state_votes integer,country_votes integer,world_votes integer);
-- 
-- alter table vote_items alter column town_votes set default 0;
-- alter table vote_items alter column state_votes set default 0;
-- alter table vote_items alter column country_votes set default 0;
-- alter table vote_items alter column world_votes set default 0;
-- 
-- alter table poll_items add column class_0 int4;
-- alter table poll_items add column class_1 int4;
-- alter table poll_items add column class_2 int4;
-- 
-- alter table poll_items add column classp_0 int4;
-- alter table poll_items add column classp_1 int4;
-- alter table poll_items add column classp_2 int4;
-- 
-- alter table poll_items alter column classp_0 set default 0;
-- alter table poll_items alter column classp_1 set default 0;
-- alter table poll_items alter column classp_2 set default 0;
-- 
-- alter table poll_items add column suggestor int4;
-- 
-- alter table poll_items alter column class_0 set default 0;
-- alter table poll_items alter column class_1 set default 0;
-- alter table poll_items alter column class_2 set default 0;
-- 
-- alter table poll_items add column status int4;
-- alter table poll_items alter column status set default 0;

-- alter table poll_items add column url text;
-- alter table vote_items add column submit_date date;
-- alter table poll_items add column submit_date date;

-- alter table people add column pt_balance int4;
-- alter table people alter column pt_balance set default 0;

-- alter table people add column cert_date date;
-- alter table people alter column pt_balance set default 0;

-- create table pt_transactions (id serial not null,from_id integer,to_id integer,amount integer,transaction_time timestamp);
-- alter table pt_transactions alter column amount set default 0;

-- alter table classifieds add column points int4;
-- alter table classifieds alter column points set default 0;

-- alter table pt_transactions add column comment text;
-- alter table pt_transactions add column comment text;

-- create table temp_key(id serial not null,key  text,sent_date date);
-- alter table people add column lastlogin timestamp;

-- create table pictures(id serial not null,owner integer,size integer,name  text,type text,md5sum text,uploaded date);
-- alter table pictures add column status text;

-- create table pic_allocation(id serial not null,picnum integer,used_by integer);

-- alter table posts add column url text;
-- alter table posts add column blurb text;

insert into subjects (subjectid,subject,item_type,description) values('VoSp','Spanish','lang','Basic Spanish Vocabulary');
insert into subjects (subjectid,subject,item_type,description) values('HoMe','Homeopathy','Info','Basic Homeopathy');

alter table items add column group_name text;
alter table items add column state int4;

create table sessions (id serial not null,session_key text);
create table session_vars (id serial not null,session_id integer,page text,key text,value text);

alter table poll_items add column num_voted  integer default 0;
alter table poll_items add column vote_tot   integer default 0;
alter table poll_items add column item_votes integer default 0;

-- remember ballots are used for many things other than polls!!!!!!!!
create table ballots (id serial not null, item_id integer, class_id integer, votes integer, type_id integer);
create table ballot_classes (id serial not null, name text, pts_per_vote integer); -- join with ballots to sum up votes (pts are really votes)
insert into ballot_classes values (0,'',1);
insert into ballot_classes values (1,'',2);
insert into ballot_classes values (2,'',10);
insert into ballot_classes values (3,'',20);
insert into ballot_classes values (4,'',45);
insert into ballot_classes values (5,'',90);
insert into ballot_classes values (6,'',105);
insert into ballot_classes values (7,'',145);
insert into ballot_classes values (8,'',205);
insert into ballot_classes values (9,'',245);

create table ballot_types (id serial not null, name text);                         -- poll plurality = 0, poll approval = 1
insert into ballot_types (id,name) values (0,'poll plurality');
insert into ballot_types (id,name) values (1,'poll approval');

alter table voted add column type_id integer;
alter table voted add column id serial not null;
create table voted_types (id serial not null, name text);
insert into voted_types (id, name) values (0, 'poll vote');                -- YES!!! WE DO NEED voted_types SEPERATE FROM ballot_types
insert into voted_types (id, name) values (1, 'council vote for poll');    -- yes, they are similar but I think combining them would be
insert into voted_types (id, name) values (2, 'council vote for item');    -- painful.
insert into voted_types (id, name) values (3, 'council vote for story');

alter table people add column email_validated integer default 0;  -- has email been validated? Hmmm... should this be a seperate table
alter table people add column grade integer default 0;            -- 

alter table voted add column grade integer default 0;

-- grade
-- 
-- 0 - no status (refusing cookies)
-- 1 - has session
-- 2 - logged in, has user id
-- 3 - email validated
-- 4 ++ add 1 for every 20 points of cert_level

alter table poll_items drop column class_0  ;
alter table poll_items drop column class_1  ;
alter table poll_items drop column class_2  ;
alter table poll_items drop column classp_0 ;
alter table poll_items drop column classp_1 ;
alter table poll_items drop column classp_2 ;
alter table poll_items drop column votes    ;
alter table poll_items drop column vote_tot ;
alter table poll_items drop column num_voted;

alter table poll_items add column a_vote_tot integer default 0; -- approval  votes total
alter table poll_items add column p_vote_tot integer default 0; -- plurality votes total

alter table people alter column num set default 0;
alter table polls add column discussion_id integer default 0;

create table poll_status (id serial not null, name text);
insert into poll_status (id,name) values (0, 'In queue'); -- just posted and in queue
insert into poll_status (id,name) values (1, 'Posted');   -- published to discussion

-- fix default cert_level
alter table people alter column cert_level set default 0;
update people set cert_level=0 where cert_level is NULL;

create table discussions (id serial not null,type_id integer,activity_state integer);
update posts set thread=id where parent=0; -- was this necessary?

insert into discussions select id,0,1 from posts where parent=0;

-- ======================================================================
-- New council stuff
--======================================================================

create table councils (id serial not null, name text, discussion_id integer default 0);
alter table  council_members add column join_date date;

-- DONE ON TANG UP TO HERE

--======================================================================
-- New locations table
--======================================================================

create table locations
         (id serial not null, parent_id integer default 0, 
          council_id integer,nick text, fullname text, 
          level_id integer, blurb text, pict_id integer);
insert into locations(council_id,nick,fullname,level_id,blurb)
    values(0,'','World',0,'Our beloved Planet Earth');
insert into locations(council_id,nick,fullname,level_id,blurb)
    values(1,'us','United States',1,'The Land of the Free');
insert into locations(parent_id,council_id,nick,fullname,level_id,blurb)
    values(1,2,'az','Arizona',2,'It''s a dry heat');

drop table location;
drop table towns;
drop table states;
drop table neighborhoods ;
drop table countries;








Added stml2/example/db/dump_db version [ce7ea67483].





1

+

pg_dump -d kiatoa | grep -v 'INSERT INTO session_vars' | grep -v 'INSERT INTO sessions' > Kiatoa.sql








Added stml2/example/docs/Setup-notes.txt version [5087f9f4e8].



















1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

1) add:

host    all         all         192.168.1.1/32        password

to the bottom of /etc/postgresql/8.2/main/pg_hba.conf

2)

ln -s /home/matt/kiatoa/kiatoa-scm/kiatoa /var/www

3) copy/update the stml.conf file

sudo cp stml.conf.template /usr/lib/cgi-bin/.stml.conf
sudo vi /usr/lib/cgi-bin/.stml.conf









Added stml2/example/docs/comments.txt version [77b3863af7].
























1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+


If we had any at all of the alternative voting ideas like instant runoff, Condorcet, any of them, I think it might make the whole process better

My thought was to get people familiar with approval voting, then get people to pledge only to vote for a candidate if that candidate supported approval voting. I put the beginings of a site together here: http://approvalvote.org but stopped working on it because I decided not to push the idea for this election. Morally, in my opinion, letting the neocons in for another term is unacceptable, I suspect (but don't know) that McCain is a participant of the neocon movement. Since these elections can hinge on a few hundreds of votes I thought it wasn't worth even the infintesimal risk of any activity that would get people thinking about the alternatives to the top two pulling votes away from Obama. I did think of pushing the idea in venues dominated by interest in Ron Paul but there was some beer in the fridge and, well, you can guess the rest of that story.

Although the current implementation needs major rework I do think the idea has potential.

   1. Get people to experience plurality vs approval voting. IMHO once you've tried it going back to plurality is actually quite uncomfortable.
   2. Get people to pledge to vote only for candidates that support approval voting.
   3. Get candidates to address approval voting.

Now why approval and not Condorcet, range, IRV or any one of the dozens of other voting techniques?

   1. Approval is 100% doable using existing election machines
   2. Approval is highly resistant to any meaningful strategic voting.
   3. Approval is easy for the end users. Go try doing some condorcet or IRV ranked voting. It is really tedious.
   4. IRV is *worse* than Plurality in its vunerablity to strategic voting.
   5. Condorcet is too hard to grok for most folks. I knew once how it worked but couldn't explain it to someone right now for the life of me.

In short the marginal improvement of the more complex voting solutions over approval doesn't buy much.








Added stml2/example/example/layout.css version [bbe0114338].
























































































































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
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
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+


/*-General-----------------------------------------------*/

html, body {
	margin:0px;
	padding:0px;
}

form {
	display:inline;
	margin:0px;
	padding:0px;
}

a img {
	border:none;
	margin:0px;
	padding:0px;
}

h1, h2, h3, h4, h5, h6, p, div {
	margin:0px;
	padding:0px;
}

.right {
	float:right;
}

.left{
	float:left;
}

/*-Main Layout-------------------------------------------*/

#overall {
	margin:5px 12px 0px 12px;
	padding:0px;
}

/*-Header-------------*/

.header {
	position:relative;
	height:90px;
}

/*-Footer-------------*/

.footer {
	padding:40px 0px 0px 0px;
	position:relative;
	clear:both;
}

/*-Content Area-------*/

.content {
	width:100%;
}

/*-Left Column--------*/

.leftcolumn	{
  float:left;
  width:145px;
  margin:5px;
}

.leftcolumn .node {
	margin:0px 0px 15px 0px;
}

.leftcolumn .node h1 {
	padding:0px 0px 0px 3px;
}

.leftcolumn .node ul {
	margin:0px;
	padding:0px;
}

.leftcolumn .node li {
	display:block;
	padding:0px 0px 0px 3px;
	margin:0px;
}

.leftcolumn .node li.more{
	padding:0px 0px 0px 6px;
}

/*-Center Column------*/

.centercolumn {
        margin: 5px;
	margin-left:152px;
        margin-right:200px;
	font-family:"\"}\"";
	font-family:inherit;
}

.centercolumn .node h1 {
	padding: 0px 0px 0px 13px;
}

.centercolumn .node h4 {
	margin: 15px 0px 10px 0px;
}

.centercolumn .node p {
	margin: 0px 0px 10px 0px; */
	padding: 0px 0px 0px 0px;
}  /* this seemed not to work */

.posts_0  {
	margin: 0px 0px 0px 0px;
}

.posts_1  {
	margin: 0px 0px 0px 20px;
}

.posts_2  {
	margin: 0px 0px 0px 40px;
}

.posts_3  {
	margin: 0px 0px 0px 60px;
}

.posts_4  {
	margin: 0px 0px 0px 80px;
}

.posts_5  {
	margin: 0px 0px 0px 100px;
}

.posts_6  {
	margin: 0px 0px 0px 120px;
}

.posts_7  {
	margin: 0px 0px 0px 140px;
}

.posts_8  {
	margin: 0px 0px 0px 160px;
}

.posts_9  {
	margin: 0px 0px 0px 160px;
}

.posts_10  {
	margin: 0px 0px 0px 180px;
}

/*-Right Column-------*/

.rightcolumn {
	float:right;
        width:190px;
	margin:5px 5px 0px 0px;
}

* html .rightcolumn {
	margin:3px 3px 3px 3px;
}

body>div .rightcolumn {
	margin:0px 0px 0px 0px;
}

.rightcolumn .node {
	margin:0px 0px 5px 0px;
	padding:0px;
}

.rightcolumn .node h2 {
	margin:3px 3px 3px 2px;
}

.rightcolumn .node ul {
  list-style-position:inside;
  margin:0px;
  padding:1px;
}

.rightcolumn .node ul.none {
	list-style-position:inside;
}

.rightcolumn .node ul.dot {
	list-style-position:inside;
}

.rightcolumn .node ul.books {
	list-style-position:outside;
	margin:0px 0px 0px 35px;
}

.rightcolumn .node li {
	padding:0px 0px 0px 3px;
	margin:0px;
}

/*-Remaining layout--------------------------------------*/

#title {
	top: 0px;
	left: 0px;
	position: absolute;
}

#search {
	float:left;
	margin:0px 0px 0px 30px;
}

#randomquote {
	float:right;
	margin:0px 30px 0px 0px;
}

#copyright {
	text-align:center;
	padding:15px 0px 0px 0px;
	margin:0px 0px 0px 0px;
	clear:both;
}

#bottomNav {
	text-align:center;
	margin:0px 0px 20px 0px;
	padding:0px;
}

#oldStuffNav {
	font-weight:bold;
	text-align:right;
}









Added stml2/example/example/markup.css version [2ee4a6fa76].















































































































































































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
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
227
228
229
230
231
232
233
234
235
236
237
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
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

/*-General-----------------------------------------------*/

body {
  background-color:#ffffff;
  color:#0f0f0f;
  font-family:serif;
  font-weight:normal;
  text-decoration:none; 
/*  font-size:x-small; */
  voice-family:"\"}\"";
  voice-family:inherit;
  font-size:small;
}

html>body {
  font-size:small;
}

.strong {
  font-weight:bold;
}

#red { 
  color: #ff0000
}

/*-Main Markup-------------------------------------------*/

#overall {
  background-color: #ffffff;
  color:#000000;
}

/*-Left Column--------*/

.leftcolumn .node a {
  color:#006666;
  background-color:transparent;
}

.leftcolumn .node p {
  font-size:1.2em;
  font-weight:normal;
}

.leftcolumn .node h1 {
  font-weight:normal;
  font-size:1.2em;
  color:#ffffff;
  background-color:#000000; /* #005991;  #7f9bff #006666; */
}

.leftcolumn .node h1 a {
  color:#ffffff;
  background-color:transparent;
}

.leftcolumn .node h2 {
  font-weight:bold;
  font-size:.95em;
}

.leftcolumn .node ul {
  list-style-type:none;
}

.leftcolumn .node li.more {
  font-weight:bold;
  font-size:.75em;
}

.leftcolumn .node li.selected {
  font-weight:bold;
  font-size:1.18em;
  color:#000000;
  background-color:#cccccc;
}

.leftcolumn .node li.selected a {
  color:#000000;
  background-color:transparent;
}

/*-Center Column for classifieds-*/

.centercolumn .classifieds h1 { 
  font-family:Arial, Helvetica, serif;
  font-weight:bold;
  font-size:1.38em;
  color:#000000; /* ffffff; */
  background: #5390b7; /* a6bcac; #0c1e0f; 043b0d; 1a6126; */
}

/*-Center Column------*/
.centercolumn .node {
  font-family:serif;
}

.centercolumn .node a {
  color:#006666;
  background-color:transparent;
}

.centercolumn .node h1 {
  font-family:Arial, Helvetica, serif;
  font-weight:bold;
  font-size:1.38em;
  color:#ffffff;
  background:#000000; /* #005991; */
} /* #006666 /* url('../images/slc.gif') no-repeat; */
     
.centercolumn .node h1 a {
  color:#ffffff;
  background-color:transparent;
}

.centercolumn .node h2 {
  font-weight:bold;
  font-size:1.18em;
}

.centercolumn .node h3 {
  font-weight:bold;
  font-size:.95em;
}

.centercolumn .node h4 {
  font-weight:normal;
  font-size:1.2em;
}

.centercolumn .node h4 a {
  font-weight:bold;
}

.centercolumn .node p {
  font-weight:normal;
}

.centercolumn .posts_0 h1 { 
  color:#ffffff;
  background-color:#606060;
  font-size:1.18em;
}

.centercolumn .posts_1 h1 { 
  color:#ffffff;
  background-color:#606060;
  font-size:1.18em;
}

.centercolumn .posts_2 h1 { 
  color:#ffffff;
  background-color:#606060;
  font-size:1.18em;
}

.centercolumn .posts_3 h1 { 
  color:#ffffff;
  background-color:#606060;
  font-size:1.18em;
}

.centercolumn .posts_4 h1 { 
  color:#ffffff;
  background-color:#606060;
  font-size:1.18em;
}

.centercolumn .posts_5 h1 { 
  color:#ffffff;
  background-color:#606060;
  font-size:1.18em;
}

.centercolumn .posts_6 h1 { 
  color:#ffffff;
  background-color:#606060;
  font-size:1.18em;
}

.centercolumn .posts_7 h1 { 
  color:#ffffff;
  background-color:#606060;
  font-size:1.18em;
}

.centercolumn .posts_8 h1 { 
  color:#ffffff;
  background-color:#606060;
  font-size:1.18em;
}

.centercolumn .posts_9 h1 { 
  color:#ffffff;
  background-color:#606060;
  font-size:1.18em;
}

.centercolumn .posts_10 h1 { 
  color:#ffffff;
  background-color:#606060;
  font-size:1.18em;
}

/*-Right Column-------*/

.rightcolumn .node {
  color:#000000;
  background-color:#cccccc;
  font-family:serif;
}

.rightcolumn .node a {
  color:#000000; /* #005991;  #006666; */
  background-color:transparent;
}

.rightcolumn .node h1 {
  font-family:Arial, Helvetica, serif;
  font-weight:bold;
  font-size:0.95em; /* 1.38em; */
  color:#ffffff;
  background-color: #000000; /* #005991;  #006666; */
}

.rightcolumn .node h1 a {
  color:#ffffff;
  background-color:transparent;
}

.rightcolumn .node h2 {
  font-weight:bold;
  font-size:.95em;
}

.rightcolumn .node ul.none {
  list-style-type:none;
}

.rightcolumn .node ul.dot {
  list-style-type:none;
  /* list-style-image:url('../images/listdot.gif'); */
}

.rightcolumn .node ul.books {
  list-style-type:disc;
}

/*-OSDN Navagation bar-----------------------------------*/

#OSDNNavbar {
  background-color:#999999;
  color:#000000; /* #005991; /* #006666; */
}

#OSDNNavbar div#links {
  background-color:#999999;
  color:#000000; /* #005991; /* #006666; */
}

#OSDNNavbar a {
  background-color: transparent;
  color: #000000; /* #005991; /* #006666; */
}

/*-Remaining layout--------------------------------------*/

#randomquote {
  font-size:1.2em;
  font-style:italic;
}

#copyright {
  font-size:.75em;
  font-family:Arial, Helvetica, serif;
  background-color:transparent;
  color:#000000; /* #005991; /* #006666; */
}

#copyright a {
  background-color:transparent;
  color:#000000; /* #005991; /* #006666; */
}

#bottomNav {
  background-color:transparent;
  color:#000000; /* #005991; /* #006666; */
}

#bottomNav a {
  background-color:transparent;
  color:#ffffff;
}

#oldStuffNav {
  font-weight:bold;
}









Added stml2/example/models/candidate.scm version [70b60eb247].







































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2008, Matthew Welland. matt@kiatoa.com All rights reserved.
;; 
;; models/candidates.scm
;;

(define (candidate:get-top n)
  (dbi:get-rows 
   (s:db) 
   "SELECT DISTINCT id,name,url,party,desc,supports_av,date_added,score,pscore FROM candidates AS c ORDER BY score DESC LIMIT ?;" n))

;; HERE !!!! getting vote counts... DONT'USE- SEE VOTED INSTEAD
(define (candidate:get-votes candidates vote_type)
  (let ((ids (map (lambda (c)(candidate:get-id c)) candidates)))
    (dbi:get-rows (s:db)
		  (conc
		   "SELECT id,sum(votes*(1+score)) WHERE vote_date>"
		   (- (current-time) (* 24 60 60 7)) ;; seven days
		   " AND id IN "
		   (apply conc (intersperse ids ","))))))
		   
(define (candidate:get-by-name name)
  (dbi:get-one-row (s:db) "SELECT id,name,url,party,desc,supports_av,date_added,score,pscore FROM candidates WHERE name=?;" name))

;; update an existing candidate or create if new
(define (candidate:update dat)
  (let* ((name   (candidate:get-name dat))
	 (olddat (candidate:get-by-name name)))
    (if olddat
	(begin
	  (dbi:exec (s:db) 
		    "UPDATE candidates SET url=?,party=?,desc=?,supports_av=? WHERE name=?;"
		    (candidate:get-url   dat)
		    (candidate:get-party dat)
		    (candidate:get-desc  dat)
		    (candidate:get-supports-av dat)
		    name)
	  (candidate:get-by-name name))
	(begin
	  (dbi:exec (s:db)
		    "INSERT INTO candidates (name,url,party,desc,supports_av) VALUES(?,?,?,?,?);"
		    name
		    (candidate:get-url   dat)
		    (candidate:get-party dat)
		    (candidate:get-desc  dat)
		    (candidate:get-supports-av dat))
	  (candidate:get-by-name name)))))


(define (candidate:get-id           dat)(vector-ref dat 0)) 
(define (candidate:get-name         dat)(vector-ref dat 1)) 
(define (candidate:get-url          dat)(vector-ref dat 2))
(define (candidate:get-party        dat)(vector-ref dat 3))
(define (candidate:get-desc         dat)(vector-ref dat 4))
(define (candidate:get-supports-av  dat)(vector-ref dat 5))
(define (candidate:get-date-added   dat)(vector-ref dat 6))
(define (candidate:get-score        dat)(vector-ref dat 7))
(define (candidate:get-pscore       dat)(vector-ref dat 8))

(define (candidate:set-id!          dat val)(vector-set! dat 0 val)) 
(define (candidate:set-name!        dat val)(vector-set! dat 1 val)) 
(define (candidate:set-url!         dat val)(vector-set! dat 2 val))
(define (candidate:set-party!       dat val)(vector-set! dat 3 val))
(define (candidate:set-desc!        dat val)(vector-set! dat 4 val))
(define (candidate:set-supports-av! dat val)(vector-set! dat 5 val))
(define (candidate:set-date-added!  dat val)(vector-set! dat 6 val))
(define (candidate:set-score!       dat val)(vector-set! dat 7 val))









Added stml2/example/models/maint.scm version [236b7343e4].





























































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2008, Matthew Welland. matt@kiatoa.com All rights reserved.
;; 
;; maint/control.scm
;;

;; evolve your schema here!
;; Add entries and then go to http:/your-url/maint
;;
;; first make maint:db available as a global
;;
(define maint:db (slot-ref s:session 'conn))

;; you can store lambda's or SQL queries to be exectuted
;; be extremely careful - especially with the lambda's!!!
(define maint:schema-updates
  (list (list 1 (lambda ()(keystore:set! maint:db "MAINTPW" "Abc123")))
	(list 2 "CREATE TABLE people (id INTEGER PRIMARY KEY,name TEXT DEFAULT '',nick TEXT DEFAULT '',email TEXT,password TEXT,status INTEGER DEFAULT 0,score INTEGER DEFAULT 0,location_id INTEGER DEFAULT 0);")
	(list 3 "CREATE TABLE candidates (id INTEGER PRIMARY KEY,name TEXT DEFAULT '',url TEXT DEFAULT '',party TEXT DEFAULT '',desc TEXT DEFAULT '',supports_av INTEGER,date_added DATETIME,score INTEGER DEFAULT 0);")
	(list 4 "CREATE TABLE votes (id INTEGER PRIMARY KEY,candidate_id INTEGER,vote_date INTEGER,votes INTEGER,score INTEGER,vote_type INTEGER);")
	(list 5 "CREATE TABLE voted (id INTEGER PRIMARY KEY,user_id INTEGER,vote_date INTEGER,score INTEGER);")
	;; location_type can be: city, town, state, region, county etc
	(list 6 "CREATE TABLE locations (id INTEGER PRIMARY KEY,parent_id INTEGER,codename TEXT,name TEXT,location_type TEXT,desc TEXT,url TEXT);")
	(list 7 "INSERT INTO locations VALUES(0,0,'ea','earth','planet','Home Planet of Humans','');")
	(list 8 "ALTER TABLE candidates ADD column pscore INTEGER DEFAULT 0;")
	))

(define (maint:am-i-maint?)
  ;; Enter a maint password - return #t if good
  #t)

(define (maint:update-tables)
  (let* ((db       (slot-ref s:session 'conn))
	 (curr-ver (s:any->number (keystore:get db "SCHEMA-VERSION"))))
    (if (not curr-ver)
	(begin
	  (keystore:set! (slot-ref s:session 'conn) "SCHEMA-VERSION" 0)
	  (set! curr-ver 0)))
    (if (null? maint:schema-updates)
	(keystore:set! (slot-ref s:session 'conn) "SCHEMA-VERSION" 0)
	(let loop ((hed (car  maint:schema-updates))
		   (tal (cdr maint:schema-updates))
		   (highest-ver 0))
	  (if (< (length hed) 2)
	      (s:log "Malformed maint:schema-updates table in maint/control.scm")
	      (let ((ver (car hed))
		    (act (cadr hed)))
		(if (> ver curr-ver) ;; need to apply this one
		    (begin
		      (if (string? act)
			  (dbi:exec db act)
			  (act))
		      ;; yes, do this for each one, just in case of a crash
		      (keystore:set! db "SCHEMA-VERSION" ver)))
		(if (null? tal)
		    highest-ver
		    (loop (car tal)(cdr tal) ver))))))))









Added stml2/example/models/person.scm version [13b176d6ef].








































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2008, Matthew Welland. matt@kiatoa.com All rights reserved.
;; 
;; models/person.scm
;;
(require "md5")

(define (person:get-dat email)
  (dbi:get-one-row (s:db) "SELECT id,name,email,status,password,score FROM people WHERE email=?;" email))

;; this effectively auto logs in using "" as the password
(define (person:create-or-get email)
  (let ((dat (person:get-dat email)))
    (if dat
	(person:authenticate email "")
	(person:set-password email ""))))

(define (person:password-match? password cryptedpw)
  (string=? (md5:digest password) cryptedpw))

(define (person:authenticate email password)
  (let ((pdat (person:get-dat email)))
    (if pdat
	;; (if (s:password-match? password (vector-ref pdat 4))
	(if (person:password-match? password (vector-ref pdat 4))
	    pdat ;; password matched, return basic record id,name,email,status
	    #f)
	#f)))

;; sets password, creates user if doesn't exist
(define (person:set-password email password)
  (let ((pdat (person:get-dat email))
	;; (cpwd (s:crypt-passwd password #f)))
        (cpwd (md5:digest password)))
    (if pdat
	(dbi:exec (s:db)
		  "UPDATE people SET password=? WHERE email=?;" 
		  cpwd
		  email)
	(dbi:exec (s:db)
		  "INSERT INTO people (name,email,password) VALUES(?,?,?);"
		  ""
		  email
		  cpwd))
    (if pdat 
	pdat
	(person:get-dat email))))

(define (person:learn_enabled? email)
  (eq? (dbi:get-one (s:db) "SELECT status FROM people WHERE email=?;" email)
       1))

(define(person:files_enabled? email)
  #f)

;; id,name,email,status,password,score
(define (person:get-id       dat)(vector-ref dat 0))
(define (person:get-name     dat)(vector-ref dat 1))
(define (person:get-email    dat)(vector-ref dat 2))
(define (person:get-status   dat)(vector-ref dat 3))
(define (person:get-password dat)(vector-ref dat 4))
(define (person:get-score    dat)(vector-ref dat 5))

(define (person:set-id!       dat val)(vector-set! dat 0 val))
(define (person:set-name!     dat val)(vector-set! dat 1 val))
(define (person:set-email!    dat val)(vector-set! dat 2 val))
(define (person:set-status!   dat val)(vector-set! dat 3 val))
(define (person:set-password! dat val)(vector-set! dat 4 val))
(define (person:set-score!    dat val)(vector-set! dat 5 val))








Added stml2/example/models/voting.scm version [5caf28d651].

































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2008, Matthew Welland. matt@kiatoa.com All rights reserved.
;; 
;; models/voting.scm
;;
;; store the votes!

;; look up the entry to which to add 
(define (voting:get-entry-id candidate-id score type)
  (dbi:get-one (s:db) "SELECT id FROM votes WHERE candidate_id=? AND score=? AND vote_type=? AND vote_date>?;"
	       candidate-id
	       score
	       type
	       (- (current-seconds) 86400))) ;; i.e. since 24 hrs ago
  
(define (voting:apply-vote dat candidate-id vote-type)
  (let* ((score (person:get-score dat))
	 (vote-entry-id (voting:get-entry-id candidate-id score vote-type)))
    (if vote-entry-id
	(dbi:exec (s:db) "UPDATE votes SET votes=votes+1 WHERE id=?;" vote-entry-id)
	(dbi:exec (s:db) "INSERT INTO votes (candidate_id,vote_date,votes,score,vote_type) VALUES(?,?,?,?,?);" 
		  candidate-id
		  (current-seconds)
		  1
		  score
		  vote-type))))

(define (voting:rollup-votes)
  (let ((adat (dbi:get-rows (s:db) 
			    "SELECT candidate_id AS id,SUM(votes*(score+1)) AS score FROM votes WHERE vote_date>? AND vote_type=1 GROUP BY candidate_id;"
			    (- (current-seconds) (* 24 60 60 7))))
	(pdat (dbi:get-rows (s:db) 
			    "SELECT candidate_id AS id,SUM(votes*(score+1)) AS score FROM votes WHERE vote_date>? AND vote_type=0 GROUP BY candidate_id;"
			    (- (current-seconds) (* 24 60 60 7)))))
    (for-each
     (lambda (row)
       (dbi:exec (s:db) "UPDATE candidates SET score=? WHERE id=?;" (vector-ref row 1)(vector-ref row 0)))
     adat)
    (for-each
     (lambda (row)
       (dbi:exec (s:db) "UPDATE candidates SET pscore=? WHERE id=?;" (vector-ref row 1)(vector-ref row 0)))
     pdat)))

;; vote_type: 0=plurality, 1=approval
(define (voting:handle-votes email approval plurality)
  (let* ((pdat (let ((e (s:session-var-get "email")))
		 (if e 
		     (person:get-dat e)
		     (person:create-or-get (if (or (not (string? email)) 
						   (string-match (regexp "^\\s*$") email))
					       "noname" 
					       email)))))) ;; is this really the logic I wanted?
    ;; (s:log "Got here eh!" " pdat: " pdat)
    (if (not pdat)
	(s:set! "errmsg" "Failed to auto log in/register, email or nick already in use. Consider reseting your password")
	(begin
	  (s:session-var-set! "email" (person:get-email pdat))
	  (voting:apply-vote pdat plurality 0)
	  (map (lambda (candidate-id)
		 (voting:apply-vote pdat candidate-id 1))
	       approval)
	  (voting:rollup-votes)))))








Added stml2/example/pages/action/view.scm version [e72ae3f7dd].























































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
;; 
(s:div 'class "node" 
       (s:h1 "Approval voting works")
       "<p>Approval voting is very resistant to strategic voting and it is 
        extremely easy to implement using existing ballot technology.
       <p>Every four years voters must
       make a painful strategic choice, either vote for the candidate
       they <b><i>really</i></b> want and risk getting saddled
       with a candidate they <b><i>don't</b></i> want, OR
       vote for the most palatable frontrunner, and send a false
       message of disinterest in their true choice."
       (s:h1 "Thinking is required for a democracy to work")
       "<p>Consider trying the &quot;fool test&quot; on an unsuspecting friend or aquaintence.
        . Pick a popular smear or other known distortion aimed at a candidate you suspect your
        &quot;person under test&quot;, or PUT,
        doesn't like. Research the item and find out the truth about it as
        best you can. Start with <A target=\"_blank\" href=\"http://factcheck.org\">
        factcheck.org</a> but don't stop there. Use google or other search 
        engines to build up a picture of what is true.

        <p>Once you are armed with information you can apply the test. Ask your
        friend or collegue for the truth behind the smear. Be neutral. Accept
        their answer without judgement if it is incorrect. Say &quot;oh&quot;, or 
        &quot;thanks&quot; and let it be at that. Again, DO NOT CORRECT THEM!

        <p>If your PUT fails the test don't harp on them or correct them. 
        Although everyone is responsible for researching the facts many people will
        lock onto their existing ideas if challenged. Instead say something like,
        &quot;you may want to research that&quot; and accept that you are dealing with
        someone who just might be a fool, unwilling or unable to look at their
        favorite candidate with a critical eye.
        <p>Finally, be prepared to be tested yourself,
        aggressively research the smears your favored candidates put out. If they are true
        be prepared to prove it, if they are false, be prepared to put them in 
        context or simply admit they are false. No candidate will be perfect."
	(s:h1 "A strategy for change")
	"<p>Get a yes/no answer from your favored candidate about approval voting.
         If your candidate refuses to support approval voting first hear them out. If their 
         reasons are good then publish them so we can all learn from it. If their
         reasons are weak then look for an alternative candidate to support.

         <p>Improve your score here on approvalvote.org and then vote again in our front 
         page poll. Your score will adjust the power of your vote such that the poll 
         will reflect the choices of those who are willing to think. 
       
         We will advocate that everyone votes for an approval vote supporting independant 
         candidate if that candidate is at least 10% ahead of the next candidate of 
         the same leaning (i.e. liberal or conservative). Otherwise you should vote 
         for the frontrunner candidate of your choosen leaning due to the dangers of 
         plurality voting.")








Added stml2/example/pages/footer/view.scm version [619df4dd0e].









1
2
3
4
5

+
+
+
+
+

;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
;; 
;; footer
(list
 (s:div 'class "node" "This is the footer"))








Added stml2/example/pages/header/control.scm version [c7463c753e].













1
2
3
4
5
6
7
8
9

+
+
+
+
+
+
+
+
+

;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
;; 
;; header/control.scm

;; (load (s:model-path "blah"))
(define header:menu-items '(("home" "Home")("learn" "Learn")("action" "Take Action")("discussion" "Discussion")
			    ("preferences" "Preferences")))
(define header:title (let ((t (s:get-param 'section)))
		       (if t t "Home")))








Added stml2/example/pages/header/view.scm version [c14538dbad].


































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
;; 
;; header/view.scm
;;
(list
 ;; (s:div 'id "titlebar"
	(s:table
	 (s:tr
	  (s:td (s:img 'src "/www/images/approvalvote.png" 
		       'alt "ApprovalVote.com" 
		       'title "Welcome to ApprovalVote.com"))
	  (s:td 'valign "top" 'align "right"
		(s:table 'border "0" 'cellspacing "0"
			 (s:tr 
			  (s:td 'valign "center" ;; 'width "250" ;; 'rowspan "2"
				(s:a (s:small " *      NOW IS A GREAT TIME TO PUSH FOR APPROVAL VOTING!     * "))
				(s:br)))
			 (s:tr 
			  (s:td 'columnspan="3" 
				(s:center "*********")))))) ;;  header:title))))))
	 ;; this is the horizontal menus
	 (s:tr 'columnspan "4"
	       (s:table
		(s:tr
		  (map (lambda (m-item)
			 (s:td (s:small  "[" 
					 (s:a 'href (s:link-to (car m-item))(cadr m-item))
					 "]")))
		       header:menu-items)
		  )))));; )








Added stml2/example/pages/home/view.scm version [03740d3139].
















1
2
3
4
5
6
7
8
9
10
11
12

+
+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
;; 
(s:div 'class "node" 
       (s:h1 "Please Help Save Our Democracy.")
      "<p>We need approval voting to re-energize our democracy.
       Our system is in danger of failing us since it leaves us powerless
       to force change. Arguably the biggest problem lies in our use of
       plurality voting to choose leaders.
      ")
(s:div 'class "node"
       (s:h1 "Practice some approval voting now!")
       (s:call "uspresident"))








Added stml2/example/pages/index/control.scm version [733e1bc04a].










1
2
3
4
5
6

+
+
+
+
+
+

;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
;; 
;; this gets read for ALL pages. Don't weigh it down excessively!
;;
;; index/control.scm









Added stml2/example/pages/index/view.scm version [e6eeff7675].

























1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
;; 
;; index

(list
 (s:html
  (s:head
   (s:title "Approval Voting Now!")
   (s:link  'rel "stylesheet" 'type "text/css" 'href "/approvalvote/markup.css")
   (s:link  'rel "stylesheet" 'type "text/css" 'href "/approvalvote/layout.css"))
  (s:body
   (s:div 'class "header"       (s:call "header"))
   (s:div 'class "rightcolumn"  (s:call "rightcol"))
   (s:div 'class "leftcolumn"   (s:call "leftnav"))
   (s:div 'class "centercolumn"
          (let ((page    (slot-ref s:session 'page)))
            (if page
                (s:call page)
                (list (s:h2 "Home")
		      (s:call "sys-state")))))
   (s:div 'class "footer" (s:call "footer")))))








Added stml2/example/pages/learn/view.scm version [d368f45a4d].











1
2
3
4
5
6
7

+
+
+
+
+
+
+

;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
;; 
(s:div 'class "node" 
       (s:h1 "Resources")
        "<p>Two excellent sites with more information on approval voting:
         <p><A target=\"_blank\" href=\"http://approvalvoting.org\">approvalvoting.org</a>
         <p><a target=\"_blank\" href=\"http://approvalvoting.com\">approvalvoting.com</a>")








Added stml2/example/pages/leftnav/control.scm version [077adf479c].















1
2
3
4
5
6
7
8
9
10
11

+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
;; 
;; leftnav/control.scm 

;; nothing needed here yet!

(define (leftnav-action action)
  (case action
    ('logout
     (s:logout))))









Added stml2/example/pages/leftnav/view.scm version [29c5bd43ae].










































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
;; 
;; leftnav/view.scm

(list
    (s:div 
     'class "node"
     (s:h1 "Navigation")
     (let ((section (slot-ref s:session 'page)))
       (cond
	((or (not section) ;; this is home
	     (string=? section "home"))
	 "Home menu")
	((string=? section "discussions")
	 (list
	  (s:a "Filter"         'href (s:link-to "discussions" 'filter "on"))))
	((string=? section "learn")
	 (list
	  (s:a "Learn"  'href (s:link-to "learn"  'action "learn.teach"))(s:br)
	  (s:a "Test"   'href (s:link-to "learn"  'action "learn.test"))(s:br)
	  ))
	((string=? section "preferences")
	 (list 
	  (s:a "Password"       'href (s:link-to "preferences" 'action "password"))(s:br)
	  (s:a "Messages"       'href (s:link-to "preferences" 'action "messages"))(s:br)
	  (s:a "Preferences"    'href (s:link-to "preferences" 'action "preferences"))(s:br)))
	(else '( "nada" ))))
     (s:br))
    (s:div
     'class "node"
     (s:h1 "About you")
     (let ((email (s:session-var-get "email")))
       (if email
           (list email (s:br))
           "Not logged in")))
    (s:div
     'class "node"
     (s:call "pledge")))








Added stml2/example/pages/login/control.scm version [878dfed9da].





























1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
;; 
(load (s:model-path "person"))

(define (login-action action)
  (case (string->symbol action)
    ('login
     ;; the actual login code
     (s:log "Got here, doing login")
     (let ((email  (s:get-input 'email-address))
           (passwd (s:get-input 'password)))
	   ;; (person (make-person))) ;; DO WE NEED A PERSON "OBJECT"?
       (s:set! "email-address" email) ;; preserve user as email-address
       (if (and email passwd)
	   (let ((good-login (person:authenticate email passwd)))
	     (if good-login
		 (begin
		   (s:set! "msg" "Login successful!")
		   (s:session-var-set! "email" email))
		 (s:set! "msg" "Bad password or email. Please try again")))
	   (s:set! "msg" "Missing password or email"))))
    ('logout
     (s:delete-session))
    ('nada
     (s:log "Got here, action=" action))))








Added stml2/example/pages/login/view.scm version [2971ee1fb1].




























1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
;; 
;; Login view

(s:div 'class "node"
       ;; (s:p (s:get-err s:strong)) ;; error message
       (if (s:session-var-get "email") 
           (s:a "Log out" 'href (s:link-to (s:current-page) 'action "login.logout"))
           (list 
            (s:center (s:p (s:strong "Log in here!")))
	    (let ((msg (s:get "msg")))
	      (if msg
		  (begin
		    (s:del! "msg")
		    (s:err-font msg))
		  (s:null "")))
            (s:form 'action "login.login" 'method "post"
                    (s:strong "Id: (*)")(s:br)
                    (s:input-preserve 'type "text" 'name "email-address" 'size "14" 'maxlength "30")(s:br)
                    (s:strong "Password:")(s:br)
                    (s:input 'type "password" 'name "password" 'size "14" 'maxlength "30")(s:br)
                    (s:input 'type "submit"   'name "form-name"    'value "login")(s:br)
                    (s:a "Create account" 'href (s:link-to "new_account"))
                    ))))








Added stml2/example/pages/maint/control.scm version [b0f23bc746].

















1
2
3
4
5
6
7
8
9
10
11
12
13

+
+
+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2008, Matthew Welland. matt@kiatoa.com All rights reserved.
;; 
;; maint/control.scm
;;
(s:load-model "maint")

;; remember that the system will call the function <pagename>-action with the action as a parameter
(define (maint-action action)
  (let ((asym (string->symbol action)))
    (s:log "Doing action! " action)
    (case asym
      ('update_tables
       (maint:update-tables)))))








Added stml2/example/pages/maint/view.scm version [7f97c343f3].
















1
2
3
4
5
6
7
8
9
10
11
12

+
+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
;; 
;; maint/view.scm
;;
(if (maint:am-i-maint?)
    (list
     (s:h1 "Hello Maint!")
     (s:p (s:a "Update Tables" 'href (s:link-to (s:current-page) 
					'action "maint.update_tables"))))
    '())

	








Added stml2/example/pages/new_account/control.scm version [79ed917ee5].

























































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2008, Matthew Welland. matt@iatoa.com All rights reserved.
;; 
;; new_account/control.scm

(load (s:model-path "person"))

(define (new_account:validate-inputs password password-again email-address email-address-again)
  (cond
   ((or (not password)(not password-again)
        (not email-address)(not email-address-again))
    (s:set-err "Form is incomplete. Please fill in all fields and try again")
    #f)
   ((< (string-length password) 2)
    (s:set-err "Password is too short. Please try again")
    #f)
   ((not (string=? password password-again))
    (s:set-err "Passwords do not match. Please try again")
    #f)
   ((> (string-length password) 9)
    (s:set-err "Password is too long. Please try again")
    #f)
   ((not (string=? email-address email-address-again))
    (s:set-err "Email addresses provided do not match. Please try again")
    #f)
   ((and (not (string-match (regexp "^\\s*$") email-address))
         (not (string-match (regexp "^[^@]+@[^@]+\\.[^@]+$") email-address)))
    (s:set-err "Not a valid email address, please try again")
    #f)
   (else #t)))

(define (new_account-action action)
  (case (string->symbol action)
    ('create
     (s:log "Got here, doing create new account")
     (let ((password            (s:get-input 'password))
           (password-again      (s:get-input 'password-again))
           (email-address       (s:string-downcase (s:get-input 'email-address)))
           (email-address-again (s:string-downcase (s:get-input 'email-address-again))))
       ;; save preserved inputs
       (s:set! "email-address" email-address)
       (s:log "Saved inputs. Now check inputs")
       (if (new_account:validate-inputs password password-again email-address 
                                        email-address-again)
           ;; Great!! Now have good inputs
           (if (person:get-dat email-address)
	       (s:set-err "There is already an account for that email address!")
	       (let ((pdat (person:set-password email-address password)))
		 (if pdat
		     (s:set-err "SUCCESS!! You can now log in with " email-address " and your password")
		     (s:set-err "ERROR!! Unable to automatically log you on with the same credentials used to create your account. This shouldn't happen. Please send email to matt@kiatoa.com about this"))))
           ;; bad inputs
           #f)))
    ('else (s:log "Placeholder for future actions. Shouldn't get here"))))








Added stml2/example/pages/new_account/view.scm version [bc26c5b01c].































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
;; 
;; new_account/view.scm
;;
(list 
 (s:div 'class "node"
        ;; (s:p (s:get-err s:strong)) ;; error message
        (s:p "")(s:p (s:get-err s:err-font))
        (if (not (s:session-var-get "email")) ;; setting email defines "logged in"
            (s:form 'action "new_account.create" 'method "post"
                    (s:table 'border "0" 'spacing "0"
                             
                             (s:tr (s:td (s:strong "Email address:")) ;; (s:br)
                                   (s:td (s:input-preserve 'type "text" 'name "email-address" 'size "16" 'maxlength "30"))) ;; (s:br)
                             
                             (s:tr (s:td (s:strong "Email address again:")) ;; (s:br)
                                   (s:td (s:input-preserve 'type "text" 'name "email-address-again" 'size "16" 'maxlength "30"))) ;; (s:br)
                    
                             (s:tr (s:td (s:strong "Password:")) ;; (s:br)
                                   (s:td (s:input 'type "password" 'name "password" 'size "16" 'maxlength "16"))) ;; (s:br)
                             
                             (s:tr (s:td (s:strong "Password again:")) ;; (s:br)
                                   (s:td (s:input 'type "password" 'name "password-again" 'size "16" 'maxlength "16")))); (s:br)
                             
                    (s:input 'type "submit"   'name "form-name"    'value "submit"))
            (s:h1 "Welcome " (s:session-var-get "email") ":" (s:session-var-get "location") "!"))))
 








Added stml2/example/pages/pledge/view.scm version [7d0aadf21d].




















1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2008, Matthew Welland. matt@iatoa.com All rights reserved.
;; 
(s:if-sessionvar 
 "email"
 (list
  (s:h1 "Pledge now!")
  (s:fieldset 
   "Pledge"
   (s:form 'action "pledge.pledge"
	   'method "post"
	   (s:i " - I will vote" (s:b "ONLY") " for a candidate who supports approval voting!")
	   (s:table
	    (s:tr (s:td "Yes")  (s:td (s:input 'type "radio"    'name "pledge_answer" 'value "yes")))
	    (s:tr (s:td "No")   (s:td (s:input 'type "radio"    'name "pledge_answer" 'value "no")))
	    (s:tr (s:td "Maybe")(s:td (s:input 'type "radio"    'name "pledge_answer" 'value "maybe"))))
	   (s:input 'type "button" 'name "pledge_answer" 'value "Submit")))))








Added stml2/example/pages/preferences/view.scm version [fb61146f52].
















1
2
3
4
5
6
7
8
9
10
11
12

+
+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2008, Matthew Welland. matt@iatoa.com All rights reserved.
;; 
;; preferences/view.scm
;;
(s:div
 'class "node"
 (s:h1 "Register your email address")
 (s:p "Adds 9 pts to your score the first time you do it and enables very occasional email updates. If you change your email address
       you need to re-register to keep your 9 pts.")
 (s:form 'action "preferences.register_email"
	 'method "post"
	  (s:input 'type "submit" 'name "register_email" 'value "Register Email"))) 








Added stml2/example/pages/rightcol/view.scm version [f05a664b96].













1
2
3
4
5
6
7
8
9

+
+
+
+
+
+
+
+
+

;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
;; 

;; rightcol
(list
  (s:div 'class "node" 
	 (s:call "login")))

;; "This is the right-most column"))








Added stml2/example/pages/sys-state/view.scm version [b45ac32796].




















1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
;; 

;; sys-state

(list (let ((p (open-input-pipe "env")))
	(let loop ((l (read-line p))
		   (res '()))
	  (if (not (eof-object? l))
	      (loop (read-line p)(cons (list l "<BR>") res))
	      res)))
      ;; "USER=" (user-information (current-user-id))

      (s:h2 "Form data")
      (session:pp-formdat s:session)
      "argv=" (argv))








Added stml2/example/pages/uspresident/control.scm version [0387534663].












































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
;; 
;; this gets read for ALL pages. Don't weigh it down excessively!
;;
;; uspresident/control.scm

(s:load-model "candidate")
(s:load-model "voting")
(s:load-model "person")

(define candidates (candidate:get-top 10))
(define candidates:vote-sum-approval  (apply + (map candidate:get-score candidates)))
(define candidates:vote-sum-plurality (apply + (map candidate:get-pscore candidates)))
(define candidates:top-plurality-id   (let ((id       #f)
					    (topscore 0))
					(for-each (lambda (cand)
						    (if (> (candidate:get-pscore cand) topscore)
							(begin 
							  (set! topscore (candidate:get-pscore cand))
							  (set! id       (candidate:get-id cand)))))
						  candidates)
					id))
(define candidates:top-approval-id   (let ((id       #f)
					   (topscore 0))
				       (for-each (lambda (cand)
						   (if (> (candidate:get-score cand) topscore)
						       (begin 
							 (set! topscore (candidate:get-score cand))
							 (set! id       (candidate:get-id cand)))))
						 candidates)
				       id))
							   

(define (uspresident-action action)
  (let ((acsym (string->symbol action)))
    (cond
     ('vote
      (let ((button (s:get-input 'vote)))
	(cond
	 ((equal? button "Vote")
	  (let* ((approval    (s:get-input 'approval))
		 (plurality   (s:get-input 'plurality))
		 (newdat      (make-vector 9 ""))
		 (email       (s:session-var-get "email"))
		 (newcandname (s:get-input 'poll_name))
		 (nick-email  (if email email (s:get-input 'users_email))))
	    (if (not (list? approval))
		(set! approval (list approval)))
	    (if (string-match (regexp "^[a-zA-Z]+") newcandname)
		(let* ((dat (candidate:get-by-name newcandname)))
		  (if dat ;; i.e. this is a new candidate
		      (set! newdat dat)
		      (begin
			(candidate:set-name! newdat newcandname)
			(candidate:set-supports-av! newdat (s:get-input 'poll_supports_av))
			(candidate:set-party! newdat (s:get-input 'poll_party))
			(candidate:set-url! newdat (s:get-input 'poll_url))
			(set! newdat (candidate:update newdat))))
		  (s:log "cid: " (candidate:get-id newdat))
		  (set! approval  (cons (candidate:get-id newdat) approval))
		  (set! plurality (candidate:get-id newdat))))
	    (set! approval (filter (lambda (x)(or (number? x)(string? x))) approval)) ;; clean the approval list
	    (s:log "using email: " nick-email)
	    (s:log "approval: " approval)
	    (s:log "plurality: " plurality)
	    (if (and approval plurality (not (null? approval)))
		(begin
		  (voting:handle-votes nick-email
				       approval
				       plurality)
		  (s:session-var-set! "voted" "yes"))
		(s:set! "errmsg" "Please select one plurality vote and one or more approval votes"))))))))))








Added stml2/example/pages/uspresident/view.scm version [00ad05ecb3].

























































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
;; 

;; Note: the (list is actually no longer needed. 

(list
 (s:if-sessionvar 
  "email"
  (s:if-sessionvar 
   "voted"
   "We are glad you tried approval voting. Try again to see how the system works. Don't worry about the poll numbers. This poll is for you to play with."))
 (s:fieldset
  "Poll"
  (s:center
   (s:if-param "errmsg"
	       (let ((err (s:get "errmsg")))
		 (s:del! "errmsg")
		 (s:err-font err)))
   (s:form  'action "uspresident.vote"
	    'method "post"
	    (s:table 'border "1" 'cellspacing "0"
		     (s:tr 
		      (s:td "Candidate")(s:td "Party")(s:td "Supports approval?")
		      (s:if-sessionvar 
		       "voted"
		       (list (s:td "Plurality")
			     (s:td "Approval")
			     (s:td "Plurality" (conc "(" candidates:vote-sum-plurality "votes" ")"))
			     (s:td "Approval"  (conc "(" candidates:vote-sum-plurality "votes" ")")))
		       (list (s:td "Plurality (vote for one only)")(s:td "Approval (vote for all which you approve of)"))))
		     ;; map the poll items for each row
		     (map (lambda (candidate)
			    (let ((poll-item-id          (number->string (candidate:get-id candidate)))
				  (poll-item-url         (s:tidy-url (candidate:get-url candidate)))
				  (poll-item-name        (candidate:get-name candidate))
				  (poll-item-description (candidate:get-desc candidate))
				  (poll-item-percent-a   (quotient (* 100 (candidate:get-score candidate)) candidates:vote-sum-plurality))
				  (poll-item-percent-p   (quotient (* 100 (candidate:get-pscore candidate)) candidates:vote-sum-plurality)))
			      (list
			       (s:tr
				(s:td
				 (if poll-item-url
				     (s:a 'href poll-item-url 'target "_blank" poll-item-name)
				     poll-item-name))
				;; (if (poll:poll 'have-description?)
				;;     (s:td 'bgcolor "#f0f0f0" poll-item-description) ;; description
				;;     '())
				(s:td (candidate:get-party       candidate))
				(s:td (candidate:get-supports-av candidate))
				;; (if (not (s:session-var-get "voted")) ;; here are the check buttons for plurality and approval voting
				;;    (list 
				(s:td (s:center
				       (s:input 'type "radio"    'name "plurality" 'value poll-item-id)))
				(s:td (s:center
				       (s:input 'type "checkbox" 'name "approval"  'value poll-item-id)))
				(s:if-sessionvar "voted"
						 (list
						  (s:td (conc poll-item-percent-p "%") 'bgcolor (if (eq? (candidate:get-id candidate)  candidates:top-plurality-id)
												    "cyan"
												    "lightgrey")
							(conc "(" (candidate:get-pscore candidate) ")") 'align "center")
						  (s:td (conc poll-item-percent-a "%")  'bgcolor (if (eq? (candidate:get-id candidate)  candidates:top-approval-id)
												    "cyan"
												    "lightgrey")
							(conc "(" (candidate:get-score candidate) ")")  'align "center"))))))) ;; % votes
			  candidates)
		     (s:tr 
		      (s:td "Write in (name):<br>"
			    (s:input-preserve 'type "text" 'name "poll_name"  'size "15" 'maxlength "40"))
		      (s:td "Party:<br>" (s:input-preserve 'type "text" 'name "poll_party" 'size "10" 'maxlength "40"))
		      (s:td "Supports approval:<br>" (s:input-preserve 'type "text" 'name "poll_supports_av"  'size "10" 'maxlength "40"))
		      (s:td "Url:<br>"   (s:input-preserve 'type "text" 'name "poll_url"   'size "40" 'maxlength "120") 'colspan 4))
		     (s:tr
		      (s:td 'colspan 7
			    (s:center (s:input 'type "submit" 'name "vote" 'value "Vote") 
				      (s:if-sessionvar "email"
						       '()
						       (list
							"Email or nickname:" 
							(s:input-preserve 'type "text" 'name "users_email" 'size 20 'maxlength 40)
							"(required), Country code:"
							(s:input-preserve 'type "text" 'name "users_country_code" 'size 2 'maxlength 2)
							"(optional)"
							))
				       ))))))))








Added stml2/example/tests/test.scm version [f614028724].

























































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

#!/usr/local/bin/csi -q 

;; This currently requires that the stml code is available in a parallel directory.

(use test)
(if (file-exists? "test.db")
    (begin
      (print "Removing old test.db")
      (system "rm -f test.db")))

(load "../stml/misc-stml.scm")
(load "../stml/formdat.scm")
(load "../stml/stml.scm")
(load "../stml/session.scm")
(load "../stml/sqltbl.scm")
(load "../stml/html-filter.scm") ;; required for s:split-string 
(load "../stml/dbi.scm")
(load "../stml/keystore.scm")
(load "../stml/sugar.scm")

;; create a session to work with")
(setenv "REQUEST_URI" "/stmlrun?action=maint.nada")
(setenv "SCRIPT_NAME" "/cgi-bin/stmlrun")
(setenv "PATH_INFO" "/maint")
(setenv "QUERY_STRING" "action=maint.nada")
(setenv "SERVER_NAME" "localhost")
(setenv "REQUEST_METHOD" "GET")
;; (define session-name "pfNOeqUHkJ26BpU6y49IN") ;; ensure this session already exists
;; (setenv "HTTP_COOKIE" (string-append "session_key=" session-name)) ;; to09ipFJ9_2KXT96b2f9Q")

(load "../stml/setup.scm")
;; (test (string-append "Session set to existing session " session-name)
;;       session-name (slot-ref s:session 'session-key))

(s:validate-inputs)

;; test session variables

;; lazy stuff
(define *conn* (slot-ref s:session 'conn))

;; setup tables
(load "models/maint.scm")
(test "Create tables" #t (> (maint:update-tables)
			    0))

;; test person
(let ((fh (open-input-pipe "ls models/*.scm")))
  (let loop ((l (read-line fh)))
    (if (not (eof-object? l))
        (begin
          (print "loading " l)
          (load l)
          (loop (read-line fh)))))
  (close-input-port fh))

(let ((fh (open-input-pipe "find pages -name control.scm"))) ;; ls pages/*/control.scm")))
  (let loop ((l (read-line fh)))
    (if (not (eof-object? l))
        (begin
          (print "loading " l)
          (load l)
          (loop (read-line fh)))))
  (close-input-port fh))

(let ((fh (open-input-pipe "ls pages/*/view.scm")))
  (let loop ((l (read-line fh)))
    (if (not (eof-object? l))
        (begin
          (print "loading " l)
          (load l)
          (loop (read-line fh)))))
  (close-input-port fh))

;;======================================================================
;; Maint
;;======================================================================
;; 
(load "models/maint.scm")

(test "Update tables"   #t                (> (maint:update-tables))) ;;  *conn* 2 "us") 0))
(test "Add user"        "matt@kiatoa.com" (vector-ref (person:set-password "matt@kiatoa.com" "Password") 2))
(test "Authenticate"    "matt@kiatoa.com" (vector-ref (person:authenticate "matt@kiatoa.com" "Password") 2))
(test "Validate inputs" #t                (new_account:validate-inputs "Password" "Password" "matt@kiatoa.com" "matt@kiatoa.com"))









Added stml2/example/www/layout.css version [c0a14ff4c4].

























































































































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
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
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+


/*-General-----------------------------------------------*/

html, body {
	margin:0px;
	padding:0px;
}

form {
	display:inline;
	margin:0px;
	padding:0px;
}

a img {
	border:none;
	margin:0px;
	padding:0px;
}

h1, h2, h3, h4, h5, h6, p, div {
	margin:0px;
	padding:0px;
}

.right {
	float:right;
}

.left{
	float:left;
}

/*-Main Layout-------------------------------------------*/

#overall {
	/* margin:5px 12px 0px 12px; */
	padding:0px;
}

/*-Header-------------*/

.header {
        /* float:top; */
	position:relative; 
	height:55px;
}

/*-Footer-------------*/

.footer {
	padding:40px 0px 0px 0px;
	position:relative;
	clear:both;
}

/*-Content Area-------*/

.content {
	width:100%;
}

/*-Left Column--------*/

.leftcolumn	{
  float:left;
  width:145px;
  margin:5px;
}

.leftcolumn .node {
	margin:0px 0px 15px 0px;
}

.leftcolumn .node h1 {
	padding:0px 0px 0px 3px;
}

.leftcolumn .node ul {
	margin:0px;
	padding:0px;
}

.leftcolumn .node li {
	display:block;
	padding:0px 0px 0px 3px;
	margin:0px;
}

.leftcolumn .node li.more{
	padding:0px 0px 0px 6px;
}

/*-Center Column------*/

.centercolumn {
        margin: 5px;
	margin-left:152px;
        margin-right:140px;
	font-family:"\"}\"";
	font-family:inherit;
}

.centercolumn .node h1 {
	padding: 0px 0px 0px 13px;
}

.centercolumn .node h4 {
	margin: 15px 0px 10px 0px;
}

.centercolumn .node p {
	margin: 0px 0px 10px 0px; */
	padding: 0px 0px 0px 0px;
}  /* this seemed not to work */

.posts_0  {
	margin: 0px 0px 0px 0px;
}

.posts_1  {
	margin: 0px 0px 0px 20px;
}

.posts_2  {
	margin: 0px 0px 0px 40px;
}

.posts_3  {
	margin: 0px 0px 0px 60px;
}

.posts_4  {
	margin: 0px 0px 0px 80px;
}

.posts_5  {
	margin: 0px 0px 0px 100px;
}

.posts_6  {
	margin: 0px 0px 0px 120px;
}

.posts_7  {
	margin: 0px 0px 0px 140px;
}

.posts_8  {
	margin: 0px 0px 0px 160px;
}

.posts_9  {
	margin: 0px 0px 0px 160px;
}

.posts_10  {
	margin: 0px 0px 0px 180px;
}

/*-Right Column-------*/

.rightcolumn {
	float:right;
        width:130px;
	margin:5px 5px 0px 0px;
}

* html .rightcolumn {
	margin:3px 3px 3px 3px;
}

body>div .rightcolumn {
	margin:0px 0px 0px 0px;
}

.rightcolumn .node {
	margin:0px 0px 5px 0px;
	padding:0px;
}

.rightcolumn .node h2 {
	margin:3px 3px 3px 2px;
}

.rightcolumn .node ul {
  list-style-position:inside;
  margin:0px;
  padding:1px;
}

.rightcolumn .node ul.none {
	list-style-position:inside;
}

.rightcolumn .node ul.dot {
	list-style-position:inside;
}

.rightcolumn .node ul.books {
	list-style-position:outside;
	margin:0px 0px 0px 35px;
}

.rightcolumn .node li {
	padding:0px 0px 0px 3px;
	margin:0px;
}

/*-Remaining layout--------------------------------------*/

#title {
	top: 0px;
	left: 0px;
	position: absolute;
}

#search {
	float:left;
	margin:0px 0px 0px 30px;
}

#randomquote {
	float:right;
	margin:0px 30px 0px 0px;
}

#copyright {
	text-align:center;
	padding:15px 0px 0px 0px;
	margin:0px 0px 0px 0px;
	clear:both;
}

#bottomNav {
	text-align:center;
	margin:0px 0px 20px 0px;
	padding:0px;
}

#oldStuffNav {
	font-weight:bold;
	text-align:right;
}









Added stml2/example/www/markup.css version [45cda36b65].















































































































































































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
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
227
228
229
230
231
232
233
234
235
236
237
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
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

/*-General-----------------------------------------------*/

body {
  background-color:#ffffff;
  color:#0f0f0f;
/*  font-family:serif; */
  font-weight:normal;
  text-decoration:none; 
  font-size:x-small; 
  voice-family:"\"}\"";
  voice-family:inherit;
  font-size:small;
}

html>body {
  font-size:small;
}

.strong {
  font-weight:bold;
}

#red { 
  color: #ff0000
}

/*-Main Markup-------------------------------------------*/

#overall {
  background-color: #ffffff;
  color:#000000;
}

/*-Left Column--------*/

.leftcolumn .node a {
  color:#006666;
  background-color:transparent;
}

.leftcolumn .node p {
  font-size:1.2em;
  font-weight:normal;
}

.leftcolumn .node h1 {
  font-weight:normal;
  font-size:1.2em;
  color:#ffffff;
  background-color:#000000; /* #005991;  #7f9bff #006666; */
}

.leftcolumn .node h1 a {
  color:#ffffff;
  background-color:transparent;
}

.leftcolumn .node h2 {
  font-weight:bold;
  font-size:.95em;
}

.leftcolumn .node ul {
  list-style-type:none;
}

.leftcolumn .node li.more {
  font-weight:bold;
  font-size:.75em;
}

.leftcolumn .node li.selected {
  font-weight:bold;
  font-size:1.18em;
  color:#000000;
  background-color:#cccccc;
}

.leftcolumn .node li.selected a {
  color:#000000;
  background-color:transparent;
}

/*-Center Column for classifieds-*/

.centercolumn .classifieds h1 { 
  font-family:Arial, Helvetica, serif;
  font-weight:bold;
  font-size:1.38em;
  color:#000000; /* ffffff; */
  background: #5390b7; /* a6bcac; #0c1e0f; 043b0d; 1a6126; */
}

/*-Center Column------*/
.centercolumn .node {
/*  font-family:serif; */
}

.centercolumn .node a {
  color:#006666;
  background-color:transparent;
}

.centercolumn .node h1 {
  font-family:Arial, Helvetica, serif;
  font-weight:bold;
  font-size:1.38em;
  color:#ffffff;
  background:#000000; /* #005991; */
} /* #006666 /* url('../images/slc.gif') no-repeat; */
     
.centercolumn .node h1 a {
  color:#ffffff;
  background-color:transparent;
}

.centercolumn .node h2 {
  font-weight:bold;
  font-size:1.18em;
}

.centercolumn .node h3 {
  font-weight:bold;
  font-size:.95em;
}

.centercolumn .node h4 {
  font-weight:normal;
  font-size:1.2em;
}

.centercolumn .node h4 a {
  font-weight:bold;
}

.centercolumn .node p {
  font-weight:normal;
}

.centercolumn .posts_0 h1 { 
  color:#ffffff;
  background-color:#606060;
  font-size:1.18em;
}

.centercolumn .posts_1 h1 { 
  color:#ffffff;
  background-color:#606060;
  font-size:1.18em;
}

.centercolumn .posts_2 h1 { 
  color:#ffffff;
  background-color:#606060;
  font-size:1.18em;
}

.centercolumn .posts_3 h1 { 
  color:#ffffff;
  background-color:#606060;
  font-size:1.18em;
}

.centercolumn .posts_4 h1 { 
  color:#ffffff;
  background-color:#606060;
  font-size:1.18em;
}

.centercolumn .posts_5 h1 { 
  color:#ffffff;
  background-color:#606060;
  font-size:1.18em;
}

.centercolumn .posts_6 h1 { 
  color:#ffffff;
  background-color:#606060;
  font-size:1.18em;
}

.centercolumn .posts_7 h1 { 
  color:#ffffff;
  background-color:#606060;
  font-size:1.18em;
}

.centercolumn .posts_8 h1 { 
  color:#ffffff;
  background-color:#606060;
  font-size:1.18em;
}

.centercolumn .posts_9 h1 { 
  color:#ffffff;
  background-color:#606060;
  font-size:1.18em;
}

.centercolumn .posts_10 h1 { 
  color:#ffffff;
  background-color:#606060;
  font-size:1.18em;
}

/*-Right Column-------*/

.rightcolumn .node {
  color:#000000;
  background-color:#cccccc;
  font-family:serif;
}

.rightcolumn .node a {
  color:#000000; /* #005991;  #006666; */
  background-color:transparent;
}

.rightcolumn .node h1 {
  font-family:Arial, Helvetica, serif;
  font-weight:bold;
  font-size:0.95em; /* 1.38em; */
  color:#ffffff;
  background-color: #000000; /* #005991;  #006666; */
}

.rightcolumn .node h1 a {
  color:#ffffff;
  background-color:transparent;
}

.rightcolumn .node h2 {
  font-weight:bold;
  font-size:.95em;
}

.rightcolumn .node ul.none {
  list-style-type:none;
}

.rightcolumn .node ul.dot {
  list-style-type:none;
  /* list-style-image:url('../images/listdot.gif'); */
}

.rightcolumn .node ul.books {
  list-style-type:disc;
}

/*-OSDN Navagation bar-----------------------------------*/

#OSDNNavbar {
  background-color:#999999;
  color:#000000; /* #005991; /* #006666; */
}

#OSDNNavbar div#links {
  background-color:#999999;
  color:#000000; /* #005991; /* #006666; */
}

#OSDNNavbar a {
  background-color: transparent;
  color: #000000; /* #005991; /* #006666; */
}

/*-Remaining layout--------------------------------------*/

#randomquote {
  font-size:1.2em;
  font-style:italic;
}

#copyright {
  font-size:.75em;
  font-family:Arial, Helvetica, serif;
  background-color:transparent;
  color:#000000; /* #005991; /* #006666; */
}

#copyright a {
  background-color:transparent;
  color:#000000; /* #005991; /* #006666; */
}

#bottomNav {
  background-color:transparent;
  color:#000000; /* #005991; /* #006666; */
}

#bottomNav a {
  background-color:transparent;
  color:#ffffff;
}

#oldStuffNav {
  font-weight:bold;
}









Added stml2/formdat.scm version [f4b16c20f8].

























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.

;; (declare (unit formdat))

(module formdat
    *

(import chicken scheme data-structures extras srfi-13 ports )
(use html-filter)

(use regex)
(require-extension srfi-69)

)








Added stml2/html-filter.scm version [55ec64cff2].

























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.

;; (declare (unit html-filter))

(module html-filter
    *

(import chicken scheme data-structures extras srfi-13 ports )
(use misc-stml)

(require-extension regex)

;; 
)








Added stml2/install.cfg.template version [e6a66ae405].










1
2
3
4
5
6

+
+
+
+
+
+


TARGDIR=/usr/lib/cgi-bin
LOGDIR=/tmp/stmlrun
SQLITE3=/usr/bin/sqlite3
# this was needed on the nokia n800 :-)
# SQLITE3=/tmp/sqlite3








Added stml2/keystore.scm version [672ac89374].


























1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

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

;;======================================================================
;; The meta data key store, just a general dumping ground for values
;; only used occasionally
;;======================================================================

;; (declare (unit keystore))

(module keystore
    *

(import chicken scheme data-structures extras srfi-13 ports )

)








Added stml2/misc-stml.scm version [30ba5d90bf].




























1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

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

;;======================================================================
;; dumbobj helpers
;;======================================================================

;; (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:))
(use (prefix dbi dbi:))
)








Added stml2/modules/twiki/Makefile version [a439548019].














1
2
3
4
5
6
7
8
9
10

+
+
+
+
+
+
+
+
+
+


twiki.l.scm : twiki.l
	csi -batch -eval '(use silex)(if (lex "twiki.l" "twiki.l.scm")(exit 0)(exit 1))'

test-silex : twiki.l.scm test-silex.scm
	csc test-silex.scm

twikicount : twiki.l.scm twikicount.scm
	csc twikicount.scm









Added stml2/modules/twiki/misc-notes.txt version [1de77e33b5].


















































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

#|
telnet localhost 80
GET cgi-bin/kiatoa/twiki?image=4&wiki_key=bG9jYXRpb25zIHdvcmxk HTTP/1.1
Accept: */*
Accept-Language: en-us
Connection: Keep-Alive
Host: localhost
Referer: http://localhost/links.asp
User-Agent: Mozilla/4.0 (compatible; MSIE 5.5; Windows NT 5.0)
Accept-Encoding: gzip, deflate

GET /kiatoa/images/kiatoa.png HTTP/1.1
Accept: */*
Accept-Language: en-us
Connection: Keep-Alive
Host: localhost
Referer: http://localhost/links.asp

GET index.html HTTP/1.1
Accept: */*
Accept-Language: en-us
Connection: Keep-Alive
Host: localhost
Referer: http://localhost/links.asp

GET /cgi-bin/kiatoa/twiki?image=2&wiki_key=bG9jYXRpb25zIHdvcmxk HTTP/1.1
Accept: */*
Accept-Language: en-us
Connection: Keep-Alive
Host: localhost
Referer: http://192.168.2.1/cgi-bin/kiatoa/location/?twiki_maint=2
User-Agent: Mozilla/4.0
Accept-Encoding: gzip, deflate

HTTP/1.1 200 OK
Date: Tue, 01 Sep 2009 02:18:16 GMT
Server: Apache/2.2.11 (Ubuntu) PHP/5.2.6-3ubuntu4.2 with Suhosin-Patch
Last-Modified: Sun, 19 Jul 2009 02:47:52 GMT
ETag: "a38005-12c2-46f060c330600"
Accept-Ranges: bytes
Content-Length: 4802
Keep-Alive: timeout=15, max=100
Connection: Keep-Alive
Content-Type: image/png

|#








Added stml2/modules/twiki/tlayout.css version [b333339cf0].
















































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

/*{{{*/
* html .tiddler {height:1%;}

body {font-size:.75em; font-family:arial,helvetica; margin:0; padding:0;}

h1,h2,h3,h4,h5,h6 {font-weight:bold; text-decoration:none;}
h1,h2,h3 {padding-bottom:1px; margin-top:1.2em;margin-bottom:0.3em;}
h4,h5,h6 {margin-top:1em;}
h1 {font-size:1.35em;}
h2 {font-size:1.25em;}
h3 {font-size:1.1em;}
h4 {font-size:1em;}
h5 {font-size:.9em;}

hr {height:1px;}

a {text-decoration:none;}

dt {font-weight:bold;}

ol {list-style-type:decimal;}
ol ol {list-style-type:lower-alpha;}
ol ol ol {list-style-type:lower-roman;}
ol ol ol ol {list-style-type:decimal;}
ol ol ol ol ol {list-style-type:lower-alpha;}
ol ol ol ol ol ol {list-style-type:lower-roman;}
ol ol ol ol ol ol ol {list-style-type:decimal;}

.txtOptionInput {width:11em;}

#contentWrapper .chkOptionInput {border:0;}

.externalLink {text-decoration:underline;}

.indent {margin-left:3em;}
.outdent {margin-left:3em; text-indent:-3em;}
code.escaped {white-space:nowrap;}

.tiddlyLinkExisting {font-weight:bold;}
.tiddlyLinkNonExisting {font-style:italic;}

/* the 'a' is required for IE, otherwise it renders the whole tiddler in bold */
a.tiddlyLinkNonExisting.shadow {font-weight:bold;}

#mainMenu .tiddlyLinkExisting,
	#mainMenu .tiddlyLinkNonExisting,
	#sidebarTabs .tiddlyLinkNonExisting {font-weight:normal; font-style:normal;}
#sidebarTabs .tiddlyLinkExisting {font-weight:bold; font-style:normal;}

.header {position:relative;}
.header a:hover {background:transparent;}
.headerShadow {position:relative; padding:4.5em 0em 1em 1em; left:-1px; top:-1px;}
.headerForeground {position:absolute; padding:4.5em 0em 1em 1em; left:0px; top:0px;}

.siteTitle {font-size:3em;}
.siteSubtitle {font-size:1.2em;}

#mainMenu {position:absolute; left:0; width:10em; text-align:right; line-height:1.6em; padding:1.5em 0.5em 0.5em 0.5em; font-size:1.1em;}

#sidebar {position:absolute; right:3px; width:16em; font-size:.9em;}
#sidebarOptions {padding-top:0.3em;}
#sidebarOptions a {margin:0em 0.2em; padding:0.2em 0.3em; display:block;}
#sidebarOptions input {margin:0.4em 0.5em;}
#sidebarOptions .sliderPanel {margin-left:1em; padding:0.5em; font-size:.85em;}
#sidebarOptions .sliderPanel a {font-weight:bold; display:inline; padding:0;}
#sidebarOptions .sliderPanel input {margin:0 0 .3em 0;}
#sidebarTabs .tabContents {width:15em; overflow:hidden;}

.wizard {padding:0.1em 1em 0em 2em;}
.wizard h1 {font-size:2em; font-weight:bold; background:none; padding:0em 0em 0em 0em; margin:0.4em 0em 0.2em 0em;}
.wizard h2 {font-size:1.2em; font-weight:bold; background:none; padding:0em 0em 0em 0em; margin:0.4em 0em 0.2em 0em;}
.wizardStep {padding:1em 1em 1em 1em;}
.wizard .button {margin:0.5em 0em 0em 0em; font-size:1.2em;}
.wizardFooter {padding:0.8em 0.4em 0.8em 0em;}
.wizardFooter .status {padding:0em 0.4em 0em 0.4em; margin-left:1em;}
.wizard .button {padding:0.1em 0.2em 0.1em 0.2em;}

#messageArea {position:fixed; top:2em; right:0em; margin:0.5em; padding:0.5em; z-index:2000; _position:absolute;}
.messageToolbar {display:block; text-align:right; padding:0.2em 0.2em 0.2em 0.2em;}
#messageArea a {text-decoration:underline;}

.tiddlerPopupButton {padding:0.2em 0.2em 0.2em 0.2em;}
.popupTiddler {position: absolute; z-index:300; padding:1em 1em 1em 1em; margin:0;}

.popup {position:absolute; z-index:300; font-size:.9em; padding:0; list-style:none; margin:0;}
.popup .popupMessage {padding:0.4em;}
.popup hr {display:block; height:1px; width:auto; padding:0; margin:0.2em 0em;}
.popup li.disabled {padding:0.4em;}
.popup li a {display:block; padding:0.4em; font-weight:normal; cursor:pointer;}
.listBreak {font-size:1px; line-height:1px;}
.listBreak div {margin:2px 0;}

.tabset {padding:1em 0em 0em 0.5em;}
.tab {margin:0em 0em 0em 0.25em; padding:2px;}
.tabContents {padding:0.5em;}
.tabContents ul, .tabContents ol {margin:0; padding:0;}
.txtMainTab .tabContents li {list-style:none;}
.tabContents li.listLink { margin-left:.75em;}

#contentWrapper {display:block;}
#splashScreen {display:none;}

#displayArea {margin:1em 17em 0em 14em;}

.toolbar {text-align:right; font-size:.9em;}

.tiddler {padding:1em 1em 0em 1em;}

.missing .viewer,.missing .title {font-style:italic;}

.title {font-size:1.6em; font-weight:bold;}

.missing .subtitle {display:none;}
.subtitle {font-size:1.1em;}

.tiddler .button {padding:0.2em 0.4em;}

.tagging {margin:0.5em 0.5em 0.5em 0; float:left; display:none;}
.isTag .tagging {display:block;}
.tagged {margin:0.5em; float:right;}
.tagging, .tagged {font-size:0.9em; padding:0.25em;}
.tagging ul, .tagged ul {list-style:none; margin:0.25em; padding:0;}
.tagClear {clear:both;}

.footer {font-size:.9em;}
.footer li {display:inline;}

.annotation {padding:0.5em; margin:0.5em;}

* html .viewer pre {width:99%; padding:0 0 1em 0;}
.viewer {line-height:1.4em; padding-top:0.5em;}
.viewer .button {margin:0em 0.25em; padding:0em 0.25em;}
.viewer blockquote {line-height:1.5em; padding-left:0.8em;margin-left:2.5em;}
.viewer ul, .viewer ol {margin-left:0.5em; padding-left:1.5em;}

.viewer table, table.twtable {border-collapse:collapse; margin:0.8em 1.0em;}
.viewer th, .viewer td, .viewer tr,.viewer caption,.twtable th, .twtable td, .twtable tr,.twtable caption {padding:3px;}
table.listView {font-size:0.85em; margin:0.8em 1.0em;}
table.listView th, table.listView td, table.listView tr {padding:0px 3px 0px 3px;}

.viewer pre {padding:0.5em; margin-left:0.5em; font-size:1.2em; line-height:1.4em; overflow:auto;}
.viewer code {font-size:1.2em; line-height:1.4em;}

.editor {font-size:1.1em;}
.editor input, .editor textarea {display:block; width:100%; font:inherit;}
.editorFooter {padding:0.25em 0em; font-size:.9em;}
.editorFooter .button {padding-top:0px; padding-bottom:0px;}

.fieldsetFix {border:0; padding:0; margin:1px 0px 1px 0px;}

.sparkline {line-height:1em;}
.sparktick {outline:0;}

.zoomer {font-size:1.1em; position:absolute; overflow:hidden;}
.zoomer div {padding:1em;}

* html #backstage {width:99%;}
* html #backstageArea {width:99%;}
#backstageArea {display:none; position:relative; overflow: hidden; z-index:150; padding:0.3em 0.5em 0.3em 0.5em;}
#backstageToolbar {position:relative;}
#backstageArea a {font-weight:bold; margin-left:0.5em; padding:0.3em 0.5em 0.3em 0.5em;}
#backstageButton {display:none; position:absolute; z-index:175; top:0em; right:0em;}
#backstageButton a {padding:0.1em 0.4em 0.1em 0.4em; margin:0.1em 0.1em 0.1em 0.1em;}
#backstage {position:relative; width:100%; z-index:50;}
#backstagePanel {display:none; z-index:100; position:absolute; width:90%; margin:0em 3em 0em 3em; padding:1em 1em 1em 1em;}
.backstagePanelFooter {padding-top:0.2em; float:right;}
.backstagePanelFooter a {padding:0.2em 0.4em 0.2em 0.4em;}
#backstageCloak {display:none; z-index:20; position:absolute; width:100%; height:100px;}

.whenBackstage {display:none;}
.backstageVisible .whenBackstage {display:block;}
/*}}}*/








Added stml2/modules/twiki/twiki-mod.scm version [d4d21ad337].




























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
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
227
228
229
230
231
232
233
234
235
236
237
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
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
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
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2010, 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.

;; twiki module
(require-extension sqlite3 regex posix md5 message-digest base64)
(import (prefix base64 base64:))

;; TODO
;;
;; * Inline tiddlers [inline[TiddlerName]]
;; * Pics            [pic X Y[picname.jpg]]
;; * Move twiki parsing/expanding to mattsutils as loadable module

;; Routines intended to be overridden by end users
;;  (twiki:access keys wiki-name user-id)
;; search the code for "override" for more.

;; twiki css
;; =========
;; Block                tag
;; -----                ---
;; twiki                twiki
;; twiki body div       twiki-node
;; twiki main menu      twiki-main-menu

;; This is the currently supported mechanism. Postgres will be added later -mrw- 7/26/2009
;;
(define (twiki:open-db key . create-not-ok)
  ;; (s:log "Got to twiki:open-db with key: " key)
  (let* ((create-ok (if (null? create-not-ok) #t (car create-not-ok)))
	 (fdat      (twiki:key->fname key))
	 (basepath  (sdat-get-twikidir s:session))
	 (fpath     (car fdat))
	 (fname     (cadr fdat))
	 (fulldir   (conc basepath "/" fpath))
	 (fullname  (let ((fn (conc fulldir "/" fname)))
		      (if (sdat-get-debugmode s:session)(s:log "\ntwikipath: " fn))
		      fn))
	 (fexists   (file-exists? fullname))
	 (db        (if fexists (dbi:open 'sqlite3 (list (cons 'dbname fullname))) #f)))
    (if (and (not db)
	     (not create-ok))
	(exit 100)
	(begin
	  (if (not fexists)
	      (begin
		;; (print "fullname: " fullname)
		(if (sdat-get-debugmode s:session)
		    (s:log "\ncreating fulldir: " fulldir))
		(twiki:register-wiki key fullname)
		(system (conc "mkdir -p " fulldir)) ;; create the path
		(if (file-exists? fpath)
		    (s:log "OK: dir " fpath " has been made")
		    (s:log "ERROR: Failed to make the path for the twiki"))
		(set! db (dbi:open 'sqlite3 (list (cons 'dbname fullname))))
		(for-each 
		 (lambda (sqry)
		   ;; (print sqry)
		   (dbi:exec db sqry))
		 ;; types: 0 text, 1 jpg, 2 png, 3 svg, 4 spreadsheet, 5 audio, 6 video :: better specs to come...
		 (list
		  "CREATE TABLE pics      (id INTEGER PRIMARY KEY,name TEXT,wiki_id INTEGER,dat_id INTEGER,thumb_dat_id INTEGER,created_on INTEGER,owner_id INTEGER);"
		  "CREATE TABLE dats      (id INTEGER PRIMARY KEY,md5sum TEXT,dat BLOB,type INTEGER);"
		  ;; on every modification a new tiddlers entry is created. When displaying the tiddlers do:
		  ;;    select where created_on < somedate order by created_on desc limit 1
		  "CREATE TABLE tiddlers (id INTEGER PRIMARY KEY,wiki_id INTEGER,name TEXT,rev INTEGER,dat_id INTEGER,created_on INTEGER,owner_id INTEGER);"
		  ;; rev and tag only utilized when user sets a tag. All results from a select as above for tiddlers are set to the tag
		  "CREATE TABLE revs     (id INTEGER PRIMARY KEY,tag TEXT);"
		  ;; wikis is here for when postgresql support is added or if a sub wiki is created. 
		  "CREATE TABLE wikis    (id INTEGER PRIMARY KEY,name TEXT,created_on INTEGER);"
		  ;; access control, negative numbered groups are private groups, postive numbered groups are system groups
		  ;; permissions are on a per-wiki granularity
		  ;; access; 0=none,1=read,2=read/write
		  "CREATE TABLE perms    (id INTEGER PRIMARY KEY,wiki_id INTEGER,group_id INTEGER,access INTEGER);"
		  "CREATE TABLE groups   (id INTEGER PRIMARY KEY,name TEXT);"
		  "CREATE TABLE members  (id INTEGER PRIMARY KEY,person_id INTEGER,group_id INTEGER);"
		  ;; setup and configuration data
		  "CREATE TABLE meta     (id INTEGER PRIMARY KEY,key TEXT,val TEXT);"
		  ;; need to create an entry for *this* twiki
		  (conc "INSERT INTO wikis (id,name,created_on) VALUES (1,'main'," (current-seconds) ");")))
		;;     (conc "INSERT INTO tiddlers (wiki_id,name,created_on) VALUES(1,'MainMenu'," (current-seconds) ");")))))
		(twiki:save-tiddler db "MainMenu" "[[FirstTiddler]]" "" 1 1)))
	  ;; (sqlite3:set-busy-timeout!(dbi:db-conn db) 1000000)
	  db))))

;;======================================================================
;; twikis (db naming, sqlite vs postgresql, keys etc.
;;======================================================================

;; A wiki is specified by a list of keys, here we convert that list to a single string
(define (twiki:keys->key keys)
  (if (not (null? keys))
      (string-intersperse (map conc keys) " ")
      " "))

(define (twiki:key->fname key)
  (let* (;; (md5keypath (md5:digest key)) ;; (twiki:keys->key keys)))
	 (keypath    (twiki:web64enc key))
	 (delta      (quotient (string-length keypath) 3)) ;; 
	 (p1         (substring keypath 0           delta)) ;;  0  8))
	 (p2         (substring keypath delta       (* delta 2)));;  8 16))
	 (p3         (substring keypath (* delta 2) (* delta 3)))) ;; 16 24))
    (list (string-intersperse (list "dbs" p1 p2 p3) "/") keypath)))

;; look up the wid based on the keys, this is used for sub wikis only. I.e. a wiki instantiated inside another wiki 
;; giving a separate namespace to all the tiddlers
(define (twiki:name->wid db name) 
  (let ((wid (dbi:get-one db "SELECT id FROM wikis WHERE name=?;" name)))
    (if wid wid
	(begin
	  (dbi:exec db "INSERT INTO wikis (name,created_on) VALUES(?,?);" name (current-seconds))
	  (twiki:name->wid db name)))))

;;======================================================================
;; twiki record
;;======================================================================

;; make-vector-record twiki wiki wid name key dbh
(define (make-twiki:wiki)(make-vector 5))
(define-inline (twiki:wiki-get-wid    vec)    (vector-ref  vec 0))
(define-inline (twiki:wiki-get-name   vec)    (vector-ref  vec 1))
(define-inline (twiki:wiki-get-key    vec)    (vector-ref  vec 2))
(define-inline (twiki:wiki-get-dbh    vec)    (vector-ref  vec 3))
(define-inline (twiki:wiki-get-perms  vec)    (vector-ref  vec 4))

(define-inline (twiki:wiki-set-wid!   vec val)(vector-set! vec 0 val))
(define-inline (twiki:wiki-set-name!  vec val)(vector-set! vec 1 val))
(define-inline (twiki:wiki-set-key!   vec val)(vector-set! vec 2 val))
(define-inline (twiki:wiki-set-dbh!   vec val)(vector-set! vec 3 val))
(define-inline (twiki:wiki-set-perms! vec val)(vector-set! vec 4 val))

;;======================================================================
;; twiki misc
;;======================================================================

;; returns help html
(define (twiki:help section)
  (let ((main (twiki:div 
	       'node "twiki-help"
	       (list 
		(twiki:h3 "Help stuff")
		(twiki:pre "
Link to page:      [[Page Title]]
Heading3:          !!! The heading
Underline:         __underlined__
Table:             | cell1 | cell2 |
List:              # item1
                   ## item2
Bullet:            * item1
                   ** item2
Preformatted:      {{{stuff here}}}
Insert a picture:  [pic[PicName]]
Or with size:      [pic100x100[PicName]]
Upload the picture using the \"Pic\" link first")))))
	;;(case section
    main))

;;======================================================================
;; twiki access control
;;======================================================================

;; idea here is for the end user to redefine this routine,
;; and call twiki:interal-access if desired
;; 
;; if override is #t then give access no matter what
(define (twiki:access keys wiki-name user-id)
  '(r w))

;; Add support for storing groups, users and access internally
;; 
(define (twiki:internal-access keys wiki-name user-id)
  #f)

;;======================================================================
;; twiki registry
;;======================================================================

;; these can be overridden by end user (just create a new routine by the same name)

(define (twiki:open-registry)
  (let* ((basepath  (sdat-get-twikidir s:session))
	 (regfile   (conc basepath "/registry.db"))
	 (regexists (file-exists? regfile))
	 (db        #f))
    (if (sdat-get-debugmode s:session)
	(s:log "regfile: " regfile " regexists: " regexists " db: " db))
    (set! db (dbi:open 'sqlite3 (list (cons 'dbname regfile))))
    (if regexists
	db
	(begin
	  (for-each (lambda (stmt)(dbi:exec db stmt))
		    (list "CREATE TABLE wikis (key TEXT PRIMARY KEY,path TEXT,creation_date INTEGER,creator_id INTEGER);"))
	  db))))

(define (twiki:register-wiki key path)
  (let ((db (twiki:open-registry)))
    (dbi:exec db 
	      "INSERT OR REPLACE INTO wikis (key,path,creation_date,creator_id) VALUES(?,?,?,?);"
	      key path (current-seconds) (twiki:get-id))
    (dbi:close db)))

;;======================================================================
;; tiddlers
;;======================================================================

(define twiki:tiddler-selector "SELECT t.id,t.name,t.rev,t.dat_id,t.created_on,t.owner_id FROM tiddlers AS t INNER JOIN dats AS d ON t.dat_id=d.id")
(define (twiki:tiddler-make)(make-vector 8 #f))
(define-inline (twiki:tiddler-get-id           vec)    (vector-ref  vec 0))
(define-inline (twiki:tiddler-get-name         vec)    (vector-ref  vec 1))
(define-inline (twiki:tiddler-get-rev          vec)    (vector-ref  vec 2))
(define-inline (twiki:tiddler-get-dat-id       vec)    (vector-ref  vec 3))
(define-inline (twiki:tiddler-get-created_on   vec)    (vector-ref  vec 4))
(define-inline (twiki:tiddler-get-owner_id     vec)    (vector-ref  vec 5))
;; (define-inline (twiki:tiddler-get-dat-type     vec)    (vector-ref  vec 6))

(define-inline (twiki:tiddler-set-id!          vec val)(vector-set! vec 0 val) vec)
(define-inline (twiki:tiddler-set-name!        vec val)(vector-set! vec 1 val) vec)
(define-inline (twiki:tiddler-set-rev!         vec val)(vector-set! vec 2 val) vec)
(define-inline (twiki:tiddler-set-dat-id!      vec val)(vector-set! vec 3 val) vec)
(define-inline (twiki:tiddler-set-created_on!  vec val)(vector-set! vec 4 val) vec)
;; (define-inline (twiki:tiddler-set-owner_id!    vec val)(vector-set! vec 5 val))

;;======================================================================
;; Routines for displaying, editing, browsing etc. tiddlers
;;======================================================================	

;; should change this to take a tiddler structure?
;; This is the display of a single tiddler
(define (twiki:view dat  tkey wid tiddler wiki) ;; close, close others, edit, more
  (let ((is-not-main  (not (equal? "MainMenu" (twiki:tiddler-get-name tiddler))))
	(edit-allowed (member 'w (twiki:wiki-get-perms wiki))))
    (s:div 'class "tiddler"
	   (s:div 'class "tiddler-menu"
		  (if (equal? "MainMenu" (twiki:tiddler-get-name tiddler))
		      (if edit-allowed
			  (list (s:a "edit" 'href
				     (s:link-to (twiki:get-link-back-to-current)
						'edit_tiddler (twiki:tiddler-get-id tiddler))))
			  '())
		      (s:div 'class "tiddler-menu-internal"
		       (s:a "close" 'href (s:link-to (twiki:get-link-back-to-current) 'close_tiddler (twiki:tiddler-get-id tiddler))) "."
		       (s:a "close others" 'href (s:link-to (twiki:get-link-back-to-current) 'close_other_tiddlers (twiki:tiddler-get-id tiddler))) "."
		       (if edit-allowed
			   (s:a "edit"  'href (s:link-to (twiki:get-link-back-to-current) 'edit_tiddler (twiki:tiddler-get-id tiddler)))
			   '()))))
	    (s:p (twiki:dat->html dat wiki)))))

(define (twiki:view-tiddler db  tkey wid tiddler wiki)
  (let* ((dat-id (twiki:tiddler-get-dat-id tiddler))
	 (dat    (twiki:get-dat db dat-id))
	 (tnum   (twiki:tiddler-get-id tiddler)))
    ;; (s:log "twid: " dat-id " dat: " dat)
    (twiki:view dat  tkey wid tiddler wiki)))

;; call with param => action-name-key e.g. save-bWFpbg__-aGVsbG8gbnVyc2U_ (save main "hello nurse")
;; this one is called when an edit form is submitted (i.e. POST)
(define (twiki:action params)
  (if (and (list? params)
	   (> (length params) 0))
      (let* ((cmdln (string-split (car params) "-"))
	     (cmd   (string->symbol (car cmdln)))
	     (tkey  (twiki:web64dec (caddr cmdln)))
	     (wid   (string->number (cadr cmdln)))
	     (tdb   (twiki:open-db tkey)))
	(s:log "cmdln: " cmdln " cmd: " cmd " tkey: " tkey " wid: " wid)
	(case cmd
	  ((save)
	   (twiki:save-curr-tiddler tdb wid))
	  ((savepic)
	   (s:log "twiki:action got to savepic")
	   (twiki:save-pic-from-form tdb wid))
	  ((cancel) ;; deprecated. Use a link for this (i.e in the twiki:twiki proc
	   (s:del! (conc "CURRENT_TWIDLER_UNDER_EDIT:" wid))
	   )))))

;; generate a form for editing a twiddler tnum
(define (twiki:edit-tiddler db tkey wid tnum)
  (s:log "twiki:edit-tiddler: tkey=" tkey " wid: " wid)
  (let* ((enc-key  (twiki:web64enc tkey))
	 (tiddats  (twiki:get-tiddlers-by-num db wid (list tnum))))
    (if (null? tiddats)
	(let* ((tid    0)
	       (dat-id 0))
	  (s:set! "twiki_title" "")
	  (s:set! "twiki_body"  ""))
	(let* ((tid    (car tiddats))
	       (dat-id (twiki:tiddler-get-dat-id tid)))
	  ;; (s:log "tid: " tid " dat-id: " dat-id)
	  (s:set! "twiki_title" (twiki:tiddler-get-name tid))
	  (s:set! "twiki_body"  (twiki:get-dat db dat-id))))
    (s:form 'action (s:link-to (twiki:get-link-back-to-current)
			       'action (conc "twiki.save-" (number->string wid) "-" enc-key))
	    'method "post" ;; 'twikiname tkey ;; done, cancel, delete
	    (s:input 'type "submit"   'name "form-name" 'value "save" 'twikiname tkey)
	    ;; (s:a "done" 'href (s:link-to (twiki:get-link-back-to-current) 'save_tmenu tnum))
	    (s:a "cancel" 'href (s:link-to (twiki:get-link-back-to-current) 'cancel_tedit tnum)) "."
	    (s:a "delete" 'href (s:link-to (twiki:get-link-back-to-current) 'delete_tiddler tnum))(s:br)
	    (s:input-preserve 'type "text" 'name "twiki_title" 'size "58" 'maxlength "150")
	    (s:textarea-preserve 'type "textarea" 'name "twiki_body" 'rows "10" 'cols "65")
	    (s:p "Tags" (s:input-preserve 'type "text" 'name "twiki_tags" 'size "55" 'maxlength "150")))))

;; save a tiddler to the db for the twiki twik, getting data from the INPUT
(define (twiki:save-curr-tiddler tdb wid)
  (formdat:printall (sdat-get-formdat s:session) s:log)
  (let* ((heading (s:get-input 'twiki_title))
	 (body    (s:get-input 'twiki_body))
	 (tags    (s:get-input 'twiki_tags))
	 (uid     (twiki:get-id)))
    ;; (s:log "twiki:save-curr-tiddler heading: " heading " body: " body " tags: " tags)
    (s:set! 'twiki_title heading)
    (if body
	(begin
	  (set! body (string-chomp body))
	  (s:set! 'twiki_body  body)))
    (s:set! 'twiki_tags  tags)
    (s:del! (conc "CURRENT_TWIDLER_UNDER_EDIT:" wid))
    (let ((res (twiki:save-tiddler tdb heading body tags wid uid)))
      ;; Now, replace this twiddler number in the view list with 
      ;; the new number from the db
      (twiki:normalize-current-twiddlers tdb wid)
      (s:del! 'twiki_title)
      (s:del! 'twiki_body)
      (s:del! 'twiki_tags)
      res)
    ))

(define (twiki:normalize-current-twiddlers tdb wid)
  (let* ((cvar      (conc "CURRENT_TWIDLERS:" wid))
	 (curr-slst (s:get cvar))
	 (curr-lst  (map string->number (string-split curr-slst ",")))
	 (tdlrs     (twiki:get-tiddlers-by-num tdb wid curr-lst))
	 (names     (remove (lambda (t)(string=? "MainMenu" t))
			    (map twiki:tiddler-get-name tdlrs)))
	 (newnums   (map twiki:tiddler-get-id 
			 (map (lambda (tn)
				(twiki:get-tiddler-by-name tdb wid tn))
			      names))))
    (s:set! cvar (string-intersperse (map number->string newnums)
				     ","))))
    
;; generic save tiddler
(define (twiki:save-tiddler tdb heading body tags wid uid)
    (if (misc:non-zero-string heading)
	(let* ((prev-tid (twiki:get-tiddler-by-name tdb wid heading))
	       (prev-dat-id (if prev-tid 
				(twiki:tiddler-get-dat-id prev-tid)
				-1))
	       (dat-id (twiki:save-dat tdb body 0))) ;; 0=text
	  ;; (s:log "twiki:save-tiddler dat-id: " dat-id " body: " body)
	  (if (equal? prev-dat-id dat-id) ;; no need to insert a new record if the dat didn't change
	      #t
	      (dbi:exec tdb 
			"INSERT INTO tiddlers (wiki_id,name,dat_id,created_on,owner_id) VALUES(?,?,?,?,?);"
			wid heading dat-id (current-seconds) uid))
	  #t) ;; success
	#f))  ;; non-success

;; text=0, jpg=1, png=2
(define (twiki:save-dat db dat type)
  (let* ((md5sum (message-digest-string (md5-primitive) dat)) ;; (md5-digest dat))
	 (datid  (twiki:dat-exists? db md5sum type))
	 (datblob (if (string? dat)
		      (string->blob dat)
		      dat)))
    (if datid
	datid
	(begin
	  (case type
	    ((0)   (dbi:exec db "INSERT INTO dats (md5sum,dat,type) VALUES(?,?,?);" md5sum datblob 0))
	    ((1)   (dbi:exec db "INSERT INTO dats (md5sum,dat,type) VALUES(?,?,?);" md5sum datblob 1))
	    (else  (dbi:exec db "INSERT INTO dats (md5sum,dat,type) VALUES(?,?,?);" md5sum datblob type)))
	  (twiki:dat-exists? db md5sum type)))))
       
(define (twiki:dat-exists? db md5sum type)
  (dbi:get-one db "SELECT id FROM dats WHERE md5sum=? AND type=?;" md5sum type))

(define (twiki:get-dat db id)
  (if (and id (number? id))
      (if (< id 0)
	  ""
	  (let ((res (dbi:get-one-row db "SELECT dat,type FROM dats WHERE id=?;" id)))
	    (if res
		(case (vector-ref res 1)
		  ((0)(blob->string (vector-ref res 0)))
		  (else (vector-ref res 0)))
		#f)))
      #f))

(define (twiki:maint_area tdb wid tkey wiki)
  (let ((maint (s:get-param 'twiki_maint))
	(write-perm (member 'w (twiki:wiki-get-perms wiki))))
    (s:div 'class "twiki-menu-internal"
     (if write-perm
	 (list (s:a "Orphans"  'href (s:link-to (twiki:get-link-back-to-current) 'twiki_maint 1))(s:br)
	       (s:a "Pics"     'href (s:link-to (twiki:get-link-back-to-current) 'twiki_maint 2))(s:br)
	       (s:a "Help"     'href (s:link-to (twiki:get-link-back-to-current) 'twiki_maint 4))(s:br))
	 '())
     (s:a "Search"   'href (s:link-to (twiki:get-link-back-to-current) 'twiki_maint 3))(s:br)
     (case maint
       ((1)
	(twiki:list-orphans tdb))
       (else
	 '())))))

;;======================================================================
;; Orphans
;;======================================================================
(define (twiki:make-tiddler-list tdlrs . tnums)
  (conc (string-intersperse 
	 (map conc (delete-duplicates
		    (append (map twiki:tiddler-get-id tdlrs) tnums)))
	 ",")))

(define (twiki:get-orphans tdb)
  '())

(define (twiki:list-orphans tdb)
  '())

;;======================================================================
;; Pictures
;;======================================================================
(define (twiki:pic_mgmt tdb wid tkey)
  (s:div 
   (s:a "Add pic" 'href (s:link-to (twiki:get-link-back-to-current) 'twiki_maint 2 'twiki_maint_add_pics 1))(s:br)
   (if (s:get-param "twiki_maint_add_pics")
       (s:form 'enctype "multipart/form-data" ;; 'name "does-a-form-have-a-name"
	       (s:input 'type "file" 'name "input-picture" 'value "Upload pic")
	       (s:input 'type "submit" 'name "submit-picture" 'value "Submit")
	       'method "post" 
	       'action (s:link-to (twiki:get-link-back-to-current) 'action (conc "twiki.savepic-" (number->string wid) "-" (twiki:web64enc tkey)))
	       (s:input 'type "text" 'name "picture-name" 'value ""))
       '())
   (let ((pics (dbi:get-rows tdb "SELECT id,name,dat_id,thumb_dat_id FROM pics WHERE wiki_id=?;" wid)))
     (map (lambda (pic)
	    (s:div 'class "tiddlerthumb"
		   (s:img 'title (vector-ref pic 1) 'alt (vector-ref pic 1)
		 	  ;; 'src (s:link-to "twiki" 'wiki_key (twiki:web64enc tkey) 'image  (vector-ref pic 0)))
		 	  'src (s:link-to "twiki" 'wiki_key (conc (number->string wid) "-" (twiki:web64enc tkey))
					  'thumb  (vector-ref pic 0)))
		   ;;       (conc "twiki/" wid "/thumbs/" (vector-ref pic 0))))
		   (vector-ref pic 0) (vector-ref pic 1)))
	  pics))))

(define  (twiki:save-pic-from-form tdb wid)
  (let* ((pic-dat  (s:get-input 'input-picture))
	 (alt-name (s:get-input 'picture-name)))
    (if pic-dat
	(begin
	  (s:log "twiki:save-pic-from-form with pic-dat=" pic-dat " and alt-name=" alt-name)
	  (twiki:save-pic tdb pic-dat wid alt-name))
	#f)))

;; get pic id for a pic name, returns the latest
(define (twiki:get-pic-id tdb pic-name wid)
  (dbi:get-one tdb "SELECT pics.id FROM pics WHERE pics.name=? AND pics.wiki_id=? ORDER BY pics.id DESC LIMIT 1;" pic-name wid))

(define (twiki:save-pic tdb pic-dat wid alt)
  (let ((pic-name (car pic-dat))
	(pic-type (cadr pic-dat))
	(pic-data (caddr pic-dat))
	;; I'm not too happy with this solution but I can't seem to chomp the \n\d from the end of the string
	(alt-name (if alt (string-substitute (regexp "[^\\w ]") "" alt #t) #f)))
    (if (and alt-name
	     (string-match (regexp "\\w+") alt-name))
	(set! pic-name alt-name))
    (s:log "alt: " alt " alt-name: " alt-name)
    (if pic-data
	(let ((dat-id (twiki:save-dat tdb pic-data (twiki:mime->twiki-type pic-type)))
	      (creation-time (current-seconds)))
	  ;; (twiki:delete-pic-by-name tdb pic-name)
	  (dbi:exec tdb 
		    "INSERT INTO pics (name,wiki_id,dat_id,created_on,owner_id) VALUES(?,?,?,?,?);"
		    pic-name wid dat-id creation-time (twiki:get-id))
	  (let ((pic-id (twiki:get-pic-id tdb pic-name wid)))
	    (twiki:make-thumbnail tdb pic-id wid))
	  #t)
	#f)))

(define (twiki:get-pic-dat tdb wid pic-id)
  (dbi:get-one tdb "SELECT dat FROM pics INNER JOIN dats ON pics.dat_id=dats.id WHERE pics.id=? AND wiki_id=?;" pic-id wid))

(define (twiki:get-thumb-dat tdb wid pic-id)
  (dbi:get-one tdb "SELECT dat FROM pics INNER JOIN dats ON pics.thumb_dat_id=dats.id WHERE pics.id=? AND wiki_id=?;" pic-id wid))

;; this one sets up the Content type, puts the data into page-dat and is done
(define (twiki:return-image-dat tdb wid pic-id)
  (let ((dat  (twiki:get-pic-dat tdb wid pic-id)))
    (s:log "twiki:return-image-dat dat is: " dat " of size: " (if (blob? dat)(blob-size dat) "[not a blob]"))
    (sdat-set-page-type!    s:session 'image)
    (sdat-set-content-type! s:session "image/jpeg")
    (sdat-set-alt-page-dat! s:session dat)))
    ;; (session:alt-out s:session)))

;; this one sets up the Content type, puts the data into page-dat and is done
(define (twiki:return-thumb-dat tdb wid pic-id)
  (let ((dat  (twiki:get-thumb-dat tdb wid pic-id)))
    (s:log "twiki:return-image-dat dat is: " dat " of size: " (if (blob? dat)(blob-size dat) "[not a blob]"))
    (sdat-set-page-type!    s:session 'image)
    (sdat-set-content-type! s:session "image/jpeg")
    (sdat-set-alt-page-dat! s:session dat)))
    ;; (session:alt-out s:session)))
  
(define (twiki:make-thumbnail tdb pic-id wid)
  (let ((indat  (twiki:get-pic-dat tdb wid pic-id)))
    ;;   (outdat (open-output-string)))
    (let-values (((inp oup pid)(process "convert" (list "-size" "500x180" "-" "-thumbnail" "250x90" "-unsharp" "0x.5" "-"))))
		(write-string (blob->string indat) #f oup)
		(close-input-port oup)
		;; (write-string #f inp (blob->string indat))
		(let ((l (read-string #f inp)))
		  (close-output-port inp)
		  ;; (write-string l #f outdat)
		  (let* ((newdat (string->blob l)) ;; (get-output-string outdat)))
			 (dat-id (twiki:save-dat tdb newdat 2))) ;; bug?
		    (dbi:exec tdb "UPDATE pics SET thumb_dat_id=? WHERE id=?;" dat-id pic-id)
		    dat-id)))))

;; not tested
(define (twiki:picdat->thumbdat picdat)
  (let-values (((inp oup pid)(process "convert" ;; (list "-size" "500x180" "-" "-thumbnail" "250x90" "-unsharp" "0x.5" "-"))))
				      (list "-size" "500x180" "-" "-thumbnail" "200x70" "-unsharp" "0x.5" "-"))))
	      (write-string (blob->string picdat) #f oup)
	      (close-input-port oup)
	      ;; (write-string #f inp (blob->string indat))
	      (let ((l (read-string #f inp)))
		(close-output-port inp)
		(write-string l #f oup)
		(string->blob l))))

(define (twiki:mime->twiki-type mime-type)
  (case (string->symbol mime-type)
    ((image/jpeg) 1)
    ((image/png)  2)
    (else 0)))

;;======================================================================
;; Wiki stuff
;;======================================================================

;; curr-tiddlers is a list of the names of the current tiddlers displayed
;; tiddler-under-edit is the tiddler being edited (or #f for none).
(define (twiki:wiki name keys)
  (let ((perms   (twiki:access name keys (twiki:get-id))))
    ;; (s:log "twiki:wiki name: \"" name "\" keys: " keys)
    (if (or (not name)
	    (string=? name "")) ;; name must be "" or #f to get here and return an image
	;; handle returning pictures, note keys and name are ignored for these. They are called out in
	;; the twiki/view.scm (twiki:twiki "blah" '(nada foo)) call.
	(let ((image   (s:get-param "image"))
	      (thumb   (s:get-param "thumb")))
	  (s:log "image: " image " thumb: " thumb " wiki_key: " (s:get-param 'wiki_key))
	  (if (and (member 'r perms) image)
	      (let* ((varlst (string-split (s:get-param 'wiki_key) "-"))
		     (tkey (twiki:web64dec (cadr varlst)))
		     (wid  (string->number (car  varlst)))
		     (tdbn (twiki:open-db tkey #f)))
		(s:log "tkey: " tkey " image number: " image)
		(twiki:return-image-dat tdbn wid (string->number image)))) ;; do not return from twiki:return-image
	  (if (and (member 'r perms) thumb)
	      (let* ((varlst (string-split (s:get-param 'wiki_key) "-"))
		     (tkey   (twiki:web64dec (cadr varlst)))
		     (wid    (string->number (car  varlst)))
		     (tdbn   (twiki:open-db tkey #f)))
		(s:log "tkey: " tkey " thumb number: " image)
		(twiki:return-thumb-dat tdbn wid (string->number thumb))))) ;; do not return from twiki:return-image
	(if (not (member 'r perms)) ;; read access
	    '() ;; return a blank slate
	    (twiki:display-wiki name keys perms)))))

(define (twiki:display-wiki name keys perms)
  (let* ((wikidat  (make-twiki:wiki))
	 (tkey     (twiki:keys->key keys))
	 (tdb      (twiki:open-db tkey))
	 (wid      (twiki:name->wid tdb name))
	 (cvar     (conc "CURRENT_TWIDLERS:" wid)) ;; page var to store current twiddlers being viewed
	 (cvar-ed  (conc "CURRENT_TWIDLER_UNDER_EDIT:" wid))
	 (tnumedit (if (s:get cvar-ed) 
		       (string->number (s:get cvar-ed))
		       #f)) ;; #f => nothing to edit, -1 create a new tiddler
	 (tnumview #f)
	 (lmenu    (twiki:get-tiddlers tdb wid (list "MainMenu")))
	 ;; store tiddlers for this page/twiki in cvar (i.e. CURRENT_TWIDLERS:<wid>
	 (tdlnums  (if (s:get cvar)
		       (map string->number (string-split (s:get cvar) ","))
		       '())) ;; list of tiddler numbers
	 (tdlrs    '())
	 (tedited  (if (member 'w perms) #f #t)) ;; force no edits if not a writer
	 (edit-tmenu-id (if (and (member 'w perms)
				 (s:get-param "edit_tmenu"))
			    (string->number (s:get-param "edit_tmenu"))
			    #f))
	 (edit-tiddler (if  (and (member 'w perms)
				 (s:get-param "edit_tiddler")) ;; this handles the "edit" link in the tiddler control bar
			    (let ((t (twiki:get-tiddlers-by-num tdb wid (list (string->number (s:get-param "edit_tiddler"))))))
			      (s:log "t: " t)
			      (if t
				  (car t ) ;; should be a list of one
				  (twiki:tiddler-set-name!
				   (twiki:tiddler-set-id! (twiki:tiddler-make) -1) "NewTiddler")))
			    #f))
	 (view-tiddler (if (s:get-param "view_tiddler")
			   (let* ((tname (twiki:web64dec (s:get-param "view_tiddler")))
				  (t     (twiki:get-tiddler-by-name tdb wid tname)))
			     (s:log "t: " t)
			     (if t
				 t 
				 (begin
				   (twiki:save-tiddler tdb tname (conc "!" tname) "" wid (twiki:get-id))
				   (twiki:get-tiddler-by-name tdb wid tname))))
			   #f))
	 ) ;; image is the dat_id, keep it simple silly.

    (twiki:wiki-set-wid!  wikidat wid)
    (twiki:wiki-set-key!  wikidat tkey)
    (twiki:wiki-set-name! wikidat name)
    (twiki:wiki-set-dbh!  wikidat tdb)
    (twiki:wiki-set-perms! wikidat perms)

    ;; (s:log "edit-tmenu-id: " edit-tmenu-id " edit-tiddler: " edit-tiddler)

    ;; Handle other URI commands here
    (if (s:get-param "cancel_tedit") ;; doesn't matter which tiddler - just use this to cancel any edit
	(begin
	  (s:del! (conc "CURRENT_TWIDLER_UNDER_EDIT:" wid))
	  (set! edit-tiddler #f)
	  (set! tnumedit #f)
	  (set! view-tiddler #f)
	  (twiki:normalize-current-twiddlers tdb wid)
	  (if (s:get cvar)
	      (set! tdlnums (map string->number (string-split (s:get cvar) ","))))))
    (if (s:get-param "delete_tiddler") '())
    ;; (twiki:delete_tiddler tdb wid (string->number (s:get-param "delete_tiddler"))))

    (s:set! "TWIKI_KEY" tkey) ;; this mechanism will fail for hierarchial twikis
    ;; override the twiddler to edit when editing MainMenu
    (if edit-tiddler
	(begin
	  (set! tnumedit (twiki:tiddler-get-id edit-tiddler))
	  (s:set! 'twiki_title (twiki:tiddler-get-name edit-tiddler))
	  (s:set! 'twiki_body  (twiki:get-dat tdb (twiki:tiddler-get-dat-id edit-tiddler)))))
    (if view-tiddler
	(begin
	  (set! tnumview (twiki:tiddler-get-id view-tiddler))))
    
    ;; NOW WHAT FOR VIEW - fix the links, add to tdlst


    (if edit-tmenu-id   (set! tnumedit edit-tmenu-id))
    (if tnumedit (set! tdlnums (cons tnumedit tdlnums)))
    (if tnumview (set! tdlnums (cons tnumview tdlnums)))
    (set! tdlrs (twiki:get-tiddlers-by-num tdb wid tdlnums))

    ;; remove tdlrs from the list if close_tiddler called
    (if (s:get-param "close_tiddler")
	(set! tdlrs (let ((tnum (string->number (s:get-param "close_tiddler"))))
		      (remove (lambda (t)
				(equal? (twiki:tiddler-get-id t) tnum))
			      tdlrs))))

    ;; remove all others if close_other_tiddlers called
    (if (s:get-param "close_other_tiddlers")
	(set! tdlrs (let ((tnum (string->number (s:get-param "close_other_tiddlers"))))
		      (remove (lambda (t)
				(not (equal? (twiki:tiddler-get-id t) tnum)))
			      tdlrs))))
    
    (s:set! cvar (twiki:make-tiddler-list tdlrs))
    (if tnumedit 
	(s:set! cvar-ed tnumedit)
	(s:del! cvar-ed))

    ;; must have a MainMenu tiddler by now
    (if (null? lmenu)
	(begin
	  (twiki:save-tiddler tdb "MainMenu" "" "" wid (twiki:get-id))
	  (set! lmenu (twiki:get-tiddlers tdb wid (list "MainMenu")))))
    
    ;; get the tiddlers from the db now
    (set! result
	  (s:div 'class "twiki"
	   ;; float to the right the control menu
	   (s:div 'class "twiki-main-menu" (twiki:maint_area tdb wid tkey wikidat))
	   (twiki:view-tiddler tdb  tkey wid (car lmenu) wikidat)
	   ;; this is probably not needed as there is no reason to create tiddlers this way
	   ;; (if (eq? tnumedit -1)(twiki:edit-tiddler tdb tkey wid tnumedit) '())
	   ;; insert the picture editor window if enabled
	   (if (equal? (s:get-param "twiki_maint") "2")(twiki:pic_mgmt tdb wid tkey) '())
	   (if (equal? (s:get-param "twiki_maint") "4")(twiki:help 1) '())
	   (if (not (null? tdlrs))
	       (map (lambda (tdlr)
		      (let ((tnum  (twiki:tiddler-get-id tdlr)))
			(s:log "tnum: " tnum " tnumedit: " tnumedit)
			(if (and tnumedit (not tedited) (equal? tnumedit tnum))
			    (begin
			      (set! tedited #t) ;; only allow editing one tiddler at a time
			      (twiki:edit-tiddler tdb tkey wid tnum))
			    (twiki:view-tiddler tdb  tkey wid tdlr wikidat))))
		    tdlrs)
	       '())))
    (dbi:close tdb)
    result))

;; should do a single more efficient query but this is good enough
(define (twiki:get-tiddlers db wid tnames)
  (apply twiki:get-tiddlers-by-name db wid tnames))
;;   (let* ((tdlrs '())
;; 	 ;; (conn   (sdat-get-conn s:session))
;; 	 (namelst (conc "('" (string-intersperse (map conc tnames) "','") "')"))
;; 	 (qry     (conc twiki:tiddler-selector " WHERE t.wiki_id=? AND t.id IN " namelst ";")))
;;     ;; (print qry)
;;     (dbi:for-each-row
;;      (lambda (row)
;;        (set! tdlrs (cons row tdlrs)))
;;      db qry wid)
;;     (reverse tdlrs))) ;; !Twiki\

;; tlst is a list of tiddler nums
(define (twiki:get-tiddlers-by-num db wid tlst)
  ;; (s:log "Got to twiki:get-tiddlers with keys: " tlst " and wid: " wid)
  ;; select where created_on < somedate order by created_on desc limit 1
  (let* ((tdlrs '())
	 (tlststr (string-intersperse (map number->string tlst) ","))
	 (already-got (make-hash-table))
	 (qry    (conc twiki:tiddler-selector " WHERE t.wiki_id=? AND t.id IN (" tlststr ") ORDER BY created_on DESC;")))
    (dbi:for-each-row
     (lambda (row)
       (let ((tname (twiki:tiddler-get-name row)))
	 (if (not (hash-table-ref/default already-got tname #f))
	     (begin
	       (set! tdlrs (cons row tdlrs))
	       (hash-table-set! already-got tname #t)))))
     db qry wid)
    (if (null? tdlrs) tdlrs (reverse tdlrs)))) ;; !Twiki\nTitle, pictures, etc.\n{{{\nCode\n}}}\n[[links]]\n|table|of|stuff|\n|more|stuff|here|\n"))

;; wid = wiki id
;; returns a list of twiki:tiddlers
(define (twiki:get-tiddlers-by-name tdb wid . names)
  (let ((tdlrs '()))
    (for-each (lambda (name)
		(let ((tdlr (twiki:get-tiddler-by-name tdb wid name)))
		  (if tdlr (set! tdlrs (cons tdlr tdlrs)))))
	      names)
    (reverse tdlrs)))
;; with the right query it should be possible to do this much faster approach for twiki:get-tiddlers-by-name
;;   (let ((tdlrs '())
;; 	(namelst (conc "('" (string-intersperse names "','") "')")))
;;     (dbi:for-each-row
;;      (lambda (row)
;;        (set! tdlrs (cons row tdlrs)))
;;      tdb
;;      (conc twiki:tiddler-selector " WHERE t.wiki_id=? AND t.name IN " namelst) wid)
;;     (reverse tdlrs)))

;; get the tiddler with the given name and the max date
(define (twiki:get-tiddler-by-name tdb wid name)
  (dbi:get-one-row tdb (conc twiki:tiddler-selector " WHERE t.wiki_id=? AND t.name=? ORDER BY created_on DESC LIMIT 1;") wid name))

(define (twiki:tiddler-name->id db tname)
  (dbi:get-one db "SELECT id FROM tiddlers WHERE name=?;" tname))

;;======================================================================
;; twiki text formating, parsing and display
;;======================================================================

;; twiki formating routines (override these to change your look and feel
(define twiki:twiki-tag  s:b)
(define twiki:h3         s:h3)
(define twiki:h2         s:h2)
(define twiki:h1         s:h1)
;; (define twiki:make-tlink s:i)
(define twiki:ul         s:ul)
(define twiki:ol         s:ol)
(define twiki:li         s:li)
(define twiki:pre        s:pre)
(define twiki:p          s:p)
(define twiki:u          s:u)
(define twiki:td         s:td)
(define twiki:tr         s:tr)
(define twiki:table      s:table)
(define twiki:div        s:div)

(define (twiki:web64enc str)
  (string-substitute "=" "_" (base64:base64-encode str) #t))

(define (twiki:web64dec str)
  (base64:base64-decode (string-substitute "_" "=" str #t)))
    
(define (twiki:make-tlink text tiddlername)
  (s:a text 'href (s:link-to (twiki:get-link-back-to-current) 'view_tiddler (twiki:web64enc tiddlername))))

(define (twiki:pic pic-name size wiki)
  (let* ((tdb    (twiki:wiki-get-dbh wiki))
	 (tkey   (twiki:wiki-get-key wiki))
	 (xy     (string-split size "x"))
	 (pic-id (twiki:get-pic-id tdb pic-name (twiki:wiki-get-wid wiki)))
	 (img-lnk  (s:link-to "twiki" 'wiki_key (conc (number->string (twiki:wiki-get-wid wiki)) "-" (twiki:web64enc tkey))
			      'image  pic-id)))
    (if (and (> (length xy) 1)
	     (car xy)
	     (cadr xy)) ;; yep, have two numbers
	(s:img 'title pic-name 'alt pic-name 'width (car xy) 'height (cadr xy) 'src img-lnk)
	(s:img 'title pic-name 'alt pic-name 'src img-lnk))))

;; override these also
(define (twiki:get-id)
  (s:session-var-get "id"))

;; override this to set links inside wiki's
(define (twiki:get-link-back-to-current)
  (s:current-page))


;; regexes are listed in the order in which they should be checked

(define twiki:h3-patt (regexp "^!!!(.*)$"))
(define twiki:h2-patt (regexp "^!!(.*)$"))
(define twiki:h1-patt (regexp "^!(.*)$"))

(define twiki:tlink-patt     (regexp "^(.*)\\[\\[([^\\[\\]]*)\\]\\](.*)$"))
(define twiki:pic-patt       (regexp "^(.*)\\[pic([0-9%]*x*[0-9%]*)\\[([^\\[\\]]+)\\]\\](.*)$"))
(define twiki:underline-patt (regexp "^(.*)__(.*)__(.*)$"))
(define twiki:table-patt     (regexp "^\\|(.*)\\|$"))

;; these are for multi-line formating
(define twiki:list-patt    (regexp "^(\\*+|\\#+)(.*)$"))
(define twiki:bullet-patt  (regexp "^(\\*+)(.*)$"))
(define twiki:number-patt  (regexp "^(\\#+)(.*)$"))
(define twiki:prefor-patt  (regexp "^\\{\\{\\{$"))
(define twiki:prefor-end-patt (regexp "^\\}\\}\\}$"))

;; regex
(define t:match  #f)
(define (t-match r s)
  (let ((res (string-match r s)))
    (set! t:match res)
    res))

;; should switch to recursively processing by block?
;; (process-block dat)
;;   ...
;;   (process-block remdat)
(define (twiki:dat->html dat wiki)
  (let* ((inp        (open-input-string dat))
	 (nest-depth 0) ;; depth of nested lists
	 ;; token (i.e. line) handling stuff
	 (next-line  #f)
	 (peek-line  (lambda ()
		       next-line))
	 (get-line   (lambda ()
		       (let ((res next-line))
			 (set! next-line (read-line inp))
			 ;; (print "get-line: prev=" res " next=" next-line "\n")
			 res)))
	 (l          (get-line))) ;; discard the #f in next-line
    (twiki:read-block peek-line get-line nest-depth #f wiki)))

;; blk-type is #f for not in a block (i.e. at top level), 'pre for preformated, 'ul or 'ol
;; call with first line as legit data
;; i.e. for preform - skip the {{{ line then call read-block
;;      for # or * call with first line
(define (twiki:read-block peek-line get-line nest-depth blk-type wiki)
  (let loop ((res '())
	     (l   (peek-line))) ;; should this be a peek-line? yes!!
    ;; (print "twiki:read-block loop nest-depth="nest-depth " blk-type=" blk-type " l=" l "\n  res=" res)
    (if (eof-object? l)
	;; we are done! return the list
	res
	;; process it!
	(cond
	 ;; handle preformated text
	 ((eq? blk-type 'pre)
	  (if (t-match  twiki:prefor-end-patt l)
	      (begin
		(get-line) ;; discard the }}}
		res)       ;; end of preformatted
	      (begin
		;; (get-line) ;; discard the {{{
		(loop (append res (list (get-line)))
		      (peek-line)))))
	 ;; handle tables
	 ((eq? blk-type 'table)
	  (if (t-match twiki:table-patt l)
	      (let ((cels  (string-split (cadr t:match) "|")))
		(get-line)
		(loop (append res (twiki:tr (map twiki:td 
						 (map (lambda (x)(twiki:line->html x #f wiki)) cels))))
		      (get-line)))
	      res))
	 ;; handle lists
	 ((or (t-match twiki:bullet-patt l) ;; have *
	      (t-match twiki:number-patt l))
	  (let* ((directive (cadr t:match))
		 (levelnum (string-length directive))
		 (text     (twiki:line->html (caddr t:match) #t wiki))
		 (btype    (if (string=? "#" (substring directive 0 1))
			       'ol
			       'ul))
		 (func     (if (eq? btype 'ul)
			       twiki:ul
			       twiki:ol)))
	    ;; (print "handling " btype ": levelnum=" levelnum " text=" text " nest-depth=" nest-depth " blk-type=" blk-type)
	    (cond
	     ((not blk-type) ;; i.e first member of the list!
	      (loop (append res (func (twiki:read-block peek-line get-line levelnum btype wiki)))
		    (get-line)))
	     ((> levelnum nest-depth)
	      (loop (append res (func (twiki:read-block peek-line get-line (+ nest-depth 1) btype wiki)))
		    (peek-line)))
	     ((< levelnum nest-depth)
	      (append res (twiki:li text))) ;; return the bulleted item, don't get the next line??
	     (else
	      (get-line)
	      (loop (append res (twiki:li text))
		    (peek-line))))))
	 ((t-match twiki:prefor-patt l)
	  (get-line) ;; discard the {{{
	  (loop (append res (twiki:pre (twiki:read-block peek-line get-line nest-depth 'pre wiki)))
		(peek-line)))
	 ((t-match twiki:table-patt l)
	  (get-line)
	  (loop (append res (twiki:table 'border 1 'cellspacing 0 (twiki:read-block peek-line get-line 0 'table wiki)))
		(peek-line)))
	 (else
	  (get-line)
	  (loop (append res (twiki:line->html l #t wiki))
		(peek-line)))))))

(define (twiki:line->html dat firstcall wiki)
  (if firstcall 
      ;; process the patterns that test for beginning of line only on the first call
      (cond
       ((t-match twiki:h3-patt dat)
	(twiki:h3 (twiki:line->html (cadr t:match) #f wiki)))
       ((t-match twiki:h2-patt dat)
	(twiki:h2 (twiki:line->html (cadr t:match) #f wiki)))
       ((t-match twiki:h1-patt dat)
	(twiki:h1 (twiki:line->html (cadr t:match) #f wiki)))
       ;; why was the (s:br) here? trying without
       (else (twiki:line->html dat #f wiki)))
       ;; (else  (append (twiki:line->html dat #f wiki)(list (s:br)))));; (s:p 'class "tiddlerpar"
      ;; not firstcall so process other patterns
      (cond
       ((t-match twiki:tlink-patt dat)
	(let ((pre  (cadr   t:match))
	      (lnk  (caddr  t:match))
	      (post (cadddr t:match)))
	  (list (twiki:line->html pre #f wiki)
		(twiki:make-tlink (twiki:line->html lnk #f wiki) lnk) ;; special handling
		(twiki:line->html post #f wiki))))
       ((t-match twiki:pic-patt dat)
	(let ((pre  (cadr    t:match))
	      (size (caddr   t:match)) 
	      (pic  (cadddr  t:match))
	      (post (list-ref t:match 4)))
	  (list (twiki:line->html pre #f wiki)
		(twiki:pic pic size wiki)
		(twiki:line->html post #t wiki))))
       ((t-match twiki:underline-patt dat)
	(let ((pre  (cadr   t:match))
	      (lnk  (caddr  t:match))
	      (post (cadddr t:match)))
	  (list (twiki:line->html pre #f wiki)
		(twiki:u (twiki:line->html lnk #f wiki))
		(twiki:line->html post #f wiki))))
       ((t-match twiki:table-patt dat)
	(let ((cels  (string-split (cadr t:match) "|")))
	  (twiki:tr (map twiki:td (twiki:line->html cels #f wiki)))))
       (else (list dat)))))


#|
(twiki:dat->html "a\n{{{\nb\nc\nd\n}}}\n!e\n[[f]]\n[[g]]\n*h" wiki)
(s:output (current-output-port) (twiki:dat->html "!Testing [[my first link]]\n* Test\n* Foo\nblah" wiki))   
(s:output (current-output-port) (twiki:dat->html "[[a]]\n{{{\nb\n  c\n   d\n}}}\n*x\n[[f]]\n[[g]]\n*h" wiki))
(s:output (current-output-port)
|#









Added stml2/modules/twiki/twiki-test.scm version [ee0fdeaa83].









1
2
3
4
5

+
+
+
+
+

(include "../../stml.scm")
;; (include "../../session.scm")
(include "../../misc-stml.scm")
(include "twiki-mod.scm")









Added stml2/modules/twiki/twiki.l version [8e7948394a].





































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; twiki

period           \.
comma            ,
semicolon        \;
opensq           \[
closesq          \]
opensquig        \{
closesquig       \}

digit            [0-9]
letter           [a-zA-Z]
okchars          [_%\/\.:\*\+\-\(\)\\#']
escape           \\ 
whitespace       [ \9]
linefeed         \n
bang             !
plaintext        ({letter}|{digit}|{okchars}|{whitespace}|{linefeed})+

%%

{opensq}                        (list 'opensq     yytext)
{closesq}                       (list 'closesq    yytext)

{opensquig}                     (list 'opensquig  yytext)
{closesquig}                    (list 'closesquig yytext)

{bang}                          (list 'bang       yytext)
{plaintext}                     (list 'plaintext  yytext)

<<EOF>>                         (list 'end-of-input #f ) ;; yyline)

<<ERROR>>                       (lex-error (conc yyline " : illegal character ") (yygetc))








Added stml2/modules/twiki/twiki.l.scm version [4356cb4b0e].














































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
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
227
228
229
230
231
232
233
234
235
236
237
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
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
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
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

; *** This file starts with a copy of the file multilex.scm ***
; Copyright (C) 1997 Danny Dube', Universite' de Montre'al.
; All rights reserved.
; SILex 1.0.

;
; Gestion des Input Systems
; Fonctions a utiliser par l'usager:
;   lexer-make-IS, lexer-get-func-getc, lexer-get-func-ungetc,
;   lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset
;

; Taille initiale par defaut du buffer d'entree
(define lexer-init-buffer-len 1024)

; Numero du caractere newline
(define lexer-integer-newline (char->integer #\newline))

; Constructeur d'IS brut
(define lexer-raw-IS-maker
  (lambda (buffer read-ptr input-f counters)
    (let ((input-f          input-f)                ; Entree reelle
	  (buffer           buffer)                 ; Buffer
	  (buflen           (string-length buffer))
	  (read-ptr         read-ptr)
	  (start-ptr        1)                      ; Marque de debut de lexeme
	  (start-line       1)
	  (start-column     1)
	  (start-offset     0)
	  (end-ptr          1)                      ; Marque de fin de lexeme
	  (point-ptr        1)                      ; Le point
	  (user-ptr         1)                      ; Marque de l'usager
	  (user-line        1)
	  (user-column      1)
	  (user-offset      0)
	  (user-up-to-date? #t))                    ; Concerne la colonne seul.
      (letrec
	  ((start-go-to-end-none         ; Fonctions de depl. des marques
	    (lambda ()
	      (set! start-ptr end-ptr)))
	   (start-go-to-end-line
	    (lambda ()
	      (let loop ((ptr start-ptr) (line start-line))
		(if (= ptr end-ptr)
		    (begin
		      (set! start-ptr ptr)
		      (set! start-line line))
		    (if (char=? (string-ref buffer ptr) #\newline)
			(loop (+ ptr 1) (+ line 1))
			(loop (+ ptr 1) line))))))
	   (start-go-to-end-all
	    (lambda ()
	      (set! start-offset (+ start-offset (- end-ptr start-ptr)))
	      (let loop ((ptr start-ptr)
			 (line start-line)
			 (column start-column))
		(if (= ptr end-ptr)
		    (begin
		      (set! start-ptr ptr)
		      (set! start-line line)
		      (set! start-column column))
		    (if (char=? (string-ref buffer ptr) #\newline)
			(loop (+ ptr 1) (+ line 1) 1)
			(loop (+ ptr 1) line (+ column 1)))))))
	   (start-go-to-user-none
	    (lambda ()
	      (set! start-ptr user-ptr)))
	   (start-go-to-user-line
	    (lambda ()
	      (set! start-ptr user-ptr)
	      (set! start-line user-line)))
	   (start-go-to-user-all
	    (lambda ()
	      (set! start-line user-line)
	      (set! start-offset user-offset)
	      (if user-up-to-date?
		  (begin
		    (set! start-ptr user-ptr)
		    (set! start-column user-column))
		  (let loop ((ptr start-ptr) (column start-column))
		    (if (= ptr user-ptr)
			(begin
			  (set! start-ptr ptr)
			  (set! start-column column))
			(if (char=? (string-ref buffer ptr) #\newline)
			    (loop (+ ptr 1) 1)
			    (loop (+ ptr 1) (+ column 1))))))))
	   (end-go-to-point
	    (lambda ()
	      (set! end-ptr point-ptr)))
	   (point-go-to-start
	    (lambda ()
	      (set! point-ptr start-ptr)))
	   (user-go-to-start-none
	    (lambda ()
	      (set! user-ptr start-ptr)))
	   (user-go-to-start-line
	    (lambda ()
	      (set! user-ptr start-ptr)
	      (set! user-line start-line)))
	   (user-go-to-start-all
	    (lambda ()
	      (set! user-ptr start-ptr)
	      (set! user-line start-line)
	      (set! user-column start-column)
	      (set! user-offset start-offset)
	      (set! user-up-to-date? #t)))
	   (init-lexeme-none             ; Debute un nouveau lexeme
	    (lambda ()
	      (if (< start-ptr user-ptr)
		  (start-go-to-user-none))
	      (point-go-to-start)))
	   (init-lexeme-line
	    (lambda ()
	      (if (< start-ptr user-ptr)
		  (start-go-to-user-line))
	      (point-go-to-start)))
	   (init-lexeme-all
	    (lambda ()
	      (if (< start-ptr user-ptr)
		  (start-go-to-user-all))
	      (point-go-to-start)))
	   (get-start-line               ; Obtention des stats du debut du lxm
	    (lambda ()
	      start-line))
	   (get-start-column
	    (lambda ()
	      start-column))
	   (get-start-offset
	    (lambda ()
	      start-offset))
	   (peek-left-context            ; Obtention de caracteres (#f si EOF)
	    (lambda ()
	      (char->integer (string-ref buffer (- start-ptr 1)))))
	   (peek-char
	    (lambda ()
	      (if (< point-ptr read-ptr)
		  (char->integer (string-ref buffer point-ptr))
		  (let ((c (input-f)))
		    (if (char? c)
			(begin
			  (if (= read-ptr buflen)
			      (reorganize-buffer))
			  (string-set! buffer point-ptr c)
			  (set! read-ptr (+ point-ptr 1))
			  (char->integer c))
			(begin
			  (set! input-f (lambda () 'eof))
			  #f))))))
	   (read-char
	    (lambda ()
	      (if (< point-ptr read-ptr)
		  (let ((c (string-ref buffer point-ptr)))
		    (set! point-ptr (+ point-ptr 1))
		    (char->integer c))
		  (let ((c (input-f)))
		    (if (char? c)
			(begin
			  (if (= read-ptr buflen)
			      (reorganize-buffer))
			  (string-set! buffer point-ptr c)
			  (set! read-ptr (+ point-ptr 1))
			  (set! point-ptr read-ptr)
			  (char->integer c))
			(begin
			  (set! input-f (lambda () 'eof))
			  #f))))))
	   (get-start-end-text           ; Obtention du lexeme
	    (lambda ()
	      (substring buffer start-ptr end-ptr)))
	   (get-user-line-line           ; Fonctions pour l'usager
	    (lambda ()
	      (if (< user-ptr start-ptr)
		  (user-go-to-start-line))
	      user-line))
	   (get-user-line-all
	    (lambda ()
	      (if (< user-ptr start-ptr)
		  (user-go-to-start-all))
	      user-line))
	   (get-user-column-all
	    (lambda ()
	      (cond ((< user-ptr start-ptr)
		     (user-go-to-start-all)
		     user-column)
		    (user-up-to-date?
		     user-column)
		    (else
		     (let loop ((ptr start-ptr) (column start-column))
		       (if (= ptr user-ptr)
			   (begin
			     (set! user-column column)
			     (set! user-up-to-date? #t)
			     column)
			   (if (char=? (string-ref buffer ptr) #\newline)
			       (loop (+ ptr 1) 1)
			       (loop (+ ptr 1) (+ column 1)))))))))
	   (get-user-offset-all
	    (lambda ()
	      (if (< user-ptr start-ptr)
		  (user-go-to-start-all))
	      user-offset))
	   (user-getc-none
	    (lambda ()
	      (if (< user-ptr start-ptr)
		  (user-go-to-start-none))
	      (if (< user-ptr read-ptr)
		  (let ((c (string-ref buffer user-ptr)))
		    (set! user-ptr (+ user-ptr 1))
		    c)
		  (let ((c (input-f)))
		    (if (char? c)
			(begin
			  (if (= read-ptr buflen)
			      (reorganize-buffer))
			  (string-set! buffer user-ptr c)
			  (set! read-ptr (+ read-ptr 1))
			  (set! user-ptr read-ptr)
			  c)
			(begin
			  (set! input-f (lambda () 'eof))
			  'eof))))))
	   (user-getc-line
	    (lambda ()
	      (if (< user-ptr start-ptr)
		  (user-go-to-start-line))
	      (if (< user-ptr read-ptr)
		  (let ((c (string-ref buffer user-ptr)))
		    (set! user-ptr (+ user-ptr 1))
		    (if (char=? c #\newline)
			(set! user-line (+ user-line 1)))
		    c)
		  (let ((c (input-f)))
		    (if (char? c)
			(begin
			  (if (= read-ptr buflen)
			      (reorganize-buffer))
			  (string-set! buffer user-ptr c)
			  (set! read-ptr (+ read-ptr 1))
			  (set! user-ptr read-ptr)
			  (if (char=? c #\newline)
			      (set! user-line (+ user-line 1)))
			  c)
			(begin
			  (set! input-f (lambda () 'eof))
			  'eof))))))
	   (user-getc-all
	    (lambda ()
	      (if (< user-ptr start-ptr)
		  (user-go-to-start-all))
	      (if (< user-ptr read-ptr)
		  (let ((c (string-ref buffer user-ptr)))
		    (set! user-ptr (+ user-ptr 1))
		    (if (char=? c #\newline)
			(begin
			  (set! user-line (+ user-line 1))
			  (set! user-column 1))
			(set! user-column (+ user-column 1)))
		    (set! user-offset (+ user-offset 1))
		    c)
		  (let ((c (input-f)))
		    (if (char? c)
			(begin
			  (if (= read-ptr buflen)
			      (reorganize-buffer))
			  (string-set! buffer user-ptr c)
			  (set! read-ptr (+ read-ptr 1))
			  (set! user-ptr read-ptr)
			  (if (char=? c #\newline)
			      (begin
				(set! user-line (+ user-line 1))
				(set! user-column 1))
			      (set! user-column (+ user-column 1)))
			  (set! user-offset (+ user-offset 1))
			  c)
			(begin
			  (set! input-f (lambda () 'eof))
			  'eof))))))
	   (user-ungetc-none
	    (lambda ()
	      (if (> user-ptr start-ptr)
		  (set! user-ptr (- user-ptr 1)))))
	   (user-ungetc-line
	    (lambda ()
	      (if (> user-ptr start-ptr)
		  (begin
		    (set! user-ptr (- user-ptr 1))
		    (let ((c (string-ref buffer user-ptr)))
		      (if (char=? c #\newline)
			  (set! user-line (- user-line 1))))))))
	   (user-ungetc-all
	    (lambda ()
	      (if (> user-ptr start-ptr)
		  (begin
		    (set! user-ptr (- user-ptr 1))
		    (let ((c (string-ref buffer user-ptr)))
		      (if (char=? c #\newline)
			  (begin
			    (set! user-line (- user-line 1))
			    (set! user-up-to-date? #f))
			  (set! user-column (- user-column 1)))
		      (set! user-offset (- user-offset 1)))))))
	   (reorganize-buffer            ; Decaler ou agrandir le buffer
	    (lambda ()
	      (if (< (* 2 start-ptr) buflen)
		  (let* ((newlen (* 2 buflen))
			 (newbuf (make-string newlen))
			 (delta (- start-ptr 1)))
		    (let loop ((from (- start-ptr 1)))
		      (if (< from buflen)
			  (begin
			    (string-set! newbuf
					 (- from delta)
					 (string-ref buffer from))
			    (loop (+ from 1)))))
		    (set! buffer    newbuf)
		    (set! buflen    newlen)
		    (set! read-ptr  (- read-ptr delta))
		    (set! start-ptr (- start-ptr delta))
		    (set! end-ptr   (- end-ptr delta))
		    (set! point-ptr (- point-ptr delta))
		    (set! user-ptr  (- user-ptr delta)))
		  (let ((delta (- start-ptr 1)))
		    (let loop ((from (- start-ptr 1)))
		      (if (< from buflen)
			  (begin
			    (string-set! buffer
					 (- from delta)
					 (string-ref buffer from))
			    (loop (+ from 1)))))
		    (set! read-ptr  (- read-ptr delta))
		    (set! start-ptr (- start-ptr delta))
		    (set! end-ptr   (- end-ptr delta))
		    (set! point-ptr (- point-ptr delta))
		    (set! user-ptr  (- user-ptr delta)))))))
	(list (cons 'start-go-to-end
		    (cond ((eq? counters 'none) start-go-to-end-none)
			  ((eq? counters 'line) start-go-to-end-line)
			  ((eq? counters 'all ) start-go-to-end-all)))
	      (cons 'end-go-to-point
		    end-go-to-point)
	      (cons 'init-lexeme
		    (cond ((eq? counters 'none) init-lexeme-none)
			  ((eq? counters 'line) init-lexeme-line)
			  ((eq? counters 'all ) init-lexeme-all)))
	      (cons 'get-start-line
		    get-start-line)
	      (cons 'get-start-column
		    get-start-column)
	      (cons 'get-start-offset
		    get-start-offset)
	      (cons 'peek-left-context
		    peek-left-context)
	      (cons 'peek-char
		    peek-char)
	      (cons 'read-char
		    read-char)
	      (cons 'get-start-end-text
		    get-start-end-text)
	      (cons 'get-user-line
		    (cond ((eq? counters 'none) #f)
			  ((eq? counters 'line) get-user-line-line)
			  ((eq? counters 'all ) get-user-line-all)))
	      (cons 'get-user-column
		    (cond ((eq? counters 'none) #f)
			  ((eq? counters 'line) #f)
			  ((eq? counters 'all ) get-user-column-all)))
	      (cons 'get-user-offset
		    (cond ((eq? counters 'none) #f)
			  ((eq? counters 'line) #f)
			  ((eq? counters 'all ) get-user-offset-all)))
	      (cons 'user-getc
		    (cond ((eq? counters 'none) user-getc-none)
			  ((eq? counters 'line) user-getc-line)
			  ((eq? counters 'all ) user-getc-all)))
	      (cons 'user-ungetc
		    (cond ((eq? counters 'none) user-ungetc-none)
			  ((eq? counters 'line) user-ungetc-line)
			  ((eq? counters 'all ) user-ungetc-all))))))))

; Construit un Input System
; Le premier parametre doit etre parmi "port", "procedure" ou "string"
; Prend un parametre facultatif qui doit etre parmi
; "none", "line" ou "all"
(define lexer-make-IS
  (lambda (input-type input . largs)
    (let ((counters-type (cond ((null? largs)
				'line)
			       ((memq (car largs) '(none line all))
				(car largs))
			       (else
				'line))))
      (cond ((and (eq? input-type 'port) (input-port? input))
	     (let* ((buffer   (make-string lexer-init-buffer-len #\newline))
		    (read-ptr 1)
		    (input-f  (lambda () (read-char input))))
	       (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
	    ((and (eq? input-type 'procedure) (procedure? input))
	     (let* ((buffer   (make-string lexer-init-buffer-len #\newline))
		    (read-ptr 1)
		    (input-f  input))
	       (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
	    ((and (eq? input-type 'string) (string? input))
	     (let* ((buffer   (string-append (string #\newline) input))
		    (read-ptr (string-length buffer))
		    (input-f  (lambda () 'eof)))
	       (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))
	    (else
	     (let* ((buffer   (string #\newline))
		    (read-ptr 1)
		    (input-f  (lambda () 'eof)))
	       (lexer-raw-IS-maker buffer read-ptr input-f counters-type)))))))

; Les fonctions:
;   lexer-get-func-getc, lexer-get-func-ungetc,
;   lexer-get-func-line, lexer-get-func-column et lexer-get-func-offset
(define lexer-get-func-getc
  (lambda (IS) (cdr (assq 'user-getc IS))))
(define lexer-get-func-ungetc
  (lambda (IS) (cdr (assq 'user-ungetc IS))))
(define lexer-get-func-line
  (lambda (IS) (cdr (assq 'get-user-line IS))))
(define lexer-get-func-column
  (lambda (IS) (cdr (assq 'get-user-column IS))))
(define lexer-get-func-offset
  (lambda (IS) (cdr (assq 'get-user-offset IS))))

;
; Gestion des lexers
;

; Fabrication de lexer a partir d'arbres de decision
(define lexer-make-tree-lexer
  (lambda (tables IS)
    (letrec
	(; Contenu de la table
	 (counters-type        (vector-ref tables 0))
	 (<<EOF>>-pre-action   (vector-ref tables 1))
	 (<<ERROR>>-pre-action (vector-ref tables 2))
	 (rules-pre-actions    (vector-ref tables 3))
	 (table-nl-start       (vector-ref tables 5))
	 (table-no-nl-start    (vector-ref tables 6))
	 (trees-v              (vector-ref tables 7))
	 (acc-v                (vector-ref tables 8))

	 ; Contenu du IS
	 (IS-start-go-to-end    (cdr (assq 'start-go-to-end IS)))
	 (IS-end-go-to-point    (cdr (assq 'end-go-to-point IS)))
	 (IS-init-lexeme        (cdr (assq 'init-lexeme IS)))
	 (IS-get-start-line     (cdr (assq 'get-start-line IS)))
	 (IS-get-start-column   (cdr (assq 'get-start-column IS)))
	 (IS-get-start-offset   (cdr (assq 'get-start-offset IS)))
	 (IS-peek-left-context  (cdr (assq 'peek-left-context IS)))
	 (IS-peek-char          (cdr (assq 'peek-char IS)))
	 (IS-read-char          (cdr (assq 'read-char IS)))
	 (IS-get-start-end-text (cdr (assq 'get-start-end-text IS)))
	 (IS-get-user-line      (cdr (assq 'get-user-line IS)))
	 (IS-get-user-column    (cdr (assq 'get-user-column IS)))
	 (IS-get-user-offset    (cdr (assq 'get-user-offset IS)))
	 (IS-user-getc          (cdr (assq 'user-getc IS)))
	 (IS-user-ungetc        (cdr (assq 'user-ungetc IS)))

	 ; Resultats
	 (<<EOF>>-action   #f)
	 (<<ERROR>>-action #f)
	 (rules-actions    #f)
	 (states           #f)
	 (final-lexer      #f)

	 ; Gestion des hooks
	 (hook-list '())
	 (add-hook
	  (lambda (thunk)
	    (set! hook-list (cons thunk hook-list))))
	 (apply-hooks
	  (lambda ()
	    (let loop ((l hook-list))
	      (if (pair? l)
		  (begin
		    ((car l))
		    (loop (cdr l)))))))

	 ; Preparation des actions
	 (set-action-statics
	  (lambda (pre-action)
	    (pre-action final-lexer IS-user-getc IS-user-ungetc)))
	 (prepare-special-action-none
	  (lambda (pre-action)
	    (let ((action #f))
	      (let ((result
		     (lambda ()
		       (action "")))
		    (hook
		     (lambda ()
		       (set! action (set-action-statics pre-action)))))
		(add-hook hook)
		result))))
	 (prepare-special-action-line
	  (lambda (pre-action)
	    (let ((action #f))
	      (let ((result
		     (lambda (yyline)
		       (action "" yyline)))
		    (hook
		     (lambda ()
		       (set! action (set-action-statics pre-action)))))
		(add-hook hook)
		result))))
	 (prepare-special-action-all
	  (lambda (pre-action)
	    (let ((action #f))
	      (let ((result
		     (lambda (yyline yycolumn yyoffset)
		       (action "" yyline yycolumn yyoffset)))
		    (hook
		     (lambda ()
		       (set! action (set-action-statics pre-action)))))
		(add-hook hook)
		result))))
	 (prepare-special-action
	  (lambda (pre-action)
	    (cond ((eq? counters-type 'none)
		   (prepare-special-action-none pre-action))
		  ((eq? counters-type 'line)
		   (prepare-special-action-line pre-action))
		  ((eq? counters-type 'all)
		   (prepare-special-action-all  pre-action)))))
	 (prepare-action-yytext-none
	  (lambda (pre-action)
	    (let ((get-start-end-text IS-get-start-end-text)
		  (start-go-to-end    IS-start-go-to-end)
		  (action             #f))
	      (let ((result
		     (lambda ()
		       (let ((yytext (get-start-end-text)))
			 (start-go-to-end)
			 (action yytext))))
		    (hook
		     (lambda ()
		       (set! action (set-action-statics pre-action)))))
		(add-hook hook)
		result))))
	 (prepare-action-yytext-line
	  (lambda (pre-action)
	    (let ((get-start-end-text IS-get-start-end-text)
		  (start-go-to-end    IS-start-go-to-end)
		  (action             #f))
	      (let ((result
		     (lambda (yyline)
		       (let ((yytext (get-start-end-text)))
			 (start-go-to-end)
			 (action yytext yyline))))
		    (hook
		     (lambda ()
		       (set! action (set-action-statics pre-action)))))
		(add-hook hook)
		result))))
	 (prepare-action-yytext-all
	  (lambda (pre-action)
	    (let ((get-start-end-text IS-get-start-end-text)
		  (start-go-to-end    IS-start-go-to-end)
		  (action             #f))
	      (let ((result
		     (lambda (yyline yycolumn yyoffset)
		       (let ((yytext (get-start-end-text)))
			 (start-go-to-end)
			 (action yytext yyline yycolumn yyoffset))))
		    (hook
		     (lambda ()
		       (set! action (set-action-statics pre-action)))))
		(add-hook hook)
		result))))
	 (prepare-action-yytext
	  (lambda (pre-action)
	    (cond ((eq? counters-type 'none)
		   (prepare-action-yytext-none pre-action))
		  ((eq? counters-type 'line)
		   (prepare-action-yytext-line pre-action))
		  ((eq? counters-type 'all)
		   (prepare-action-yytext-all  pre-action)))))
	 (prepare-action-no-yytext-none
	  (lambda (pre-action)
	    (let ((start-go-to-end    IS-start-go-to-end)
		  (action             #f))
	      (let ((result
		     (lambda ()
		       (start-go-to-end)
		       (action)))
		    (hook
		     (lambda ()
		       (set! action (set-action-statics pre-action)))))
		(add-hook hook)
		result))))
	 (prepare-action-no-yytext-line
	  (lambda (pre-action)
	    (let ((start-go-to-end    IS-start-go-to-end)
		  (action             #f))
	      (let ((result
		     (lambda (yyline)
		       (start-go-to-end)
		       (action yyline)))
		    (hook
		     (lambda ()
		       (set! action (set-action-statics pre-action)))))
		(add-hook hook)
		result))))
	 (prepare-action-no-yytext-all
	  (lambda (pre-action)
	    (let ((start-go-to-end    IS-start-go-to-end)
		  (action             #f))
	      (let ((result
		     (lambda (yyline yycolumn yyoffset)
		       (start-go-to-end)
		       (action yyline yycolumn yyoffset)))
		    (hook
		     (lambda ()
		       (set! action (set-action-statics pre-action)))))
		(add-hook hook)
		result))))
	 (prepare-action-no-yytext
	  (lambda (pre-action)
	    (cond ((eq? counters-type 'none)
		   (prepare-action-no-yytext-none pre-action))
		  ((eq? counters-type 'line)
		   (prepare-action-no-yytext-line pre-action))
		  ((eq? counters-type 'all)
		   (prepare-action-no-yytext-all  pre-action)))))

	 ; Fabrique les fonctions de dispatch
	 (prepare-dispatch-err
	  (lambda (leaf)
	    (lambda (c)
	      #f)))
	 (prepare-dispatch-number
	  (lambda (leaf)
	    (let ((state-function #f))
	      (let ((result
		     (lambda (c)
		       state-function))
		    (hook
		     (lambda ()
		       (set! state-function (vector-ref states leaf)))))
		(add-hook hook)
		result))))
	 (prepare-dispatch-leaf
	  (lambda (leaf)
	    (if (eq? leaf 'err)
		(prepare-dispatch-err leaf)
		(prepare-dispatch-number leaf))))
	 (prepare-dispatch-<
	  (lambda (tree)
	    (let ((left-tree  (list-ref tree 1))
		  (right-tree (list-ref tree 2)))
	      (let ((bound      (list-ref tree 0))
		    (left-func  (prepare-dispatch-tree left-tree))
		    (right-func (prepare-dispatch-tree right-tree)))
		(lambda (c)
		  (if (< c bound)
		      (left-func c)
		      (right-func c)))))))
	 (prepare-dispatch-=
	  (lambda (tree)
	    (let ((left-tree  (list-ref tree 2))
		  (right-tree (list-ref tree 3)))
	      (let ((bound      (list-ref tree 1))
		    (left-func  (prepare-dispatch-tree left-tree))
		    (right-func (prepare-dispatch-tree right-tree)))
		(lambda (c)
		  (if (= c bound)
		      (left-func c)
		      (right-func c)))))))
	 (prepare-dispatch-tree
	  (lambda (tree)
	    (cond ((not (pair? tree))
		   (prepare-dispatch-leaf tree))
		  ((eq? (car tree) '=)
		   (prepare-dispatch-= tree))
		  (else
		   (prepare-dispatch-< tree)))))
	 (prepare-dispatch
	  (lambda (tree)
	    (let ((dicho-func (prepare-dispatch-tree tree)))
	      (lambda (c)
		(and c (dicho-func c))))))

	 ; Fabrique les fonctions de transition (read & go) et (abort)
	 (prepare-read-n-go
	  (lambda (tree)
	    (let ((dispatch-func (prepare-dispatch tree))
		  (read-char     IS-read-char))
	      (lambda ()
		(dispatch-func (read-char))))))
	 (prepare-abort
	  (lambda (tree)
	    (lambda ()
	      #f)))
	 (prepare-transition
	  (lambda (tree)
	    (if (eq? tree 'err)
		(prepare-abort     tree)
		(prepare-read-n-go tree))))

	 ; Fabrique les fonctions d'etats ([set-end] & trans)
	 (prepare-state-no-acc
	   (lambda (s r1 r2)
	     (let ((trans-func (prepare-transition (vector-ref trees-v s))))
	       (lambda (action)
		 (let ((next-state (trans-func)))
		   (if next-state
		       (next-state action)
		       action))))))
	 (prepare-state-yes-no
	  (lambda (s r1 r2)
	    (let ((peek-char       IS-peek-char)
		  (end-go-to-point IS-end-go-to-point)
		  (new-action1     #f)
		  (trans-func (prepare-transition (vector-ref trees-v s))))
	      (let ((result
		     (lambda (action)
		       (let* ((c (peek-char))
			      (new-action
			       (if (or (not c) (= c lexer-integer-newline))
				   (begin
				     (end-go-to-point)
				     new-action1)
				   action))
			      (next-state (trans-func)))
			 (if next-state
			     (next-state new-action)
			     new-action))))
		    (hook
		     (lambda ()
		       (set! new-action1 (vector-ref rules-actions r1)))))
		(add-hook hook)
		result))))
	 (prepare-state-diff-acc
	  (lambda (s r1 r2)
	    (let ((end-go-to-point IS-end-go-to-point)
		  (peek-char       IS-peek-char)
		  (new-action1     #f)
		  (new-action2     #f)
		  (trans-func (prepare-transition (vector-ref trees-v s))))
	      (let ((result
		     (lambda (action)
		       (end-go-to-point)
		       (let* ((c (peek-char))
			      (new-action
			       (if (or (not c) (= c lexer-integer-newline))
				   new-action1
				   new-action2))
			      (next-state (trans-func)))
			 (if next-state
			     (next-state new-action)
			     new-action))))
		    (hook
		     (lambda ()
		       (set! new-action1 (vector-ref rules-actions r1))
		       (set! new-action2 (vector-ref rules-actions r2)))))
		(add-hook hook)
		result))))
	 (prepare-state-same-acc
	  (lambda (s r1 r2)
	    (let ((end-go-to-point IS-end-go-to-point)
		  (trans-func (prepare-transition (vector-ref trees-v s)))
		  (new-action #f))
	      (let ((result
		     (lambda (action)
		       (end-go-to-point)
		       (let ((next-state (trans-func)))
			 (if next-state
			     (next-state new-action)
			     new-action))))
		    (hook
		     (lambda ()
		       (set! new-action (vector-ref rules-actions r1)))))
		(add-hook hook)
		result))))
	 (prepare-state
	  (lambda (s)
	    (let* ((acc (vector-ref acc-v s))
		   (r1 (car acc))
		   (r2 (cdr acc)))
	      (cond ((not r1)  (prepare-state-no-acc   s r1 r2))
		    ((not r2)  (prepare-state-yes-no   s r1 r2))
		    ((< r1 r2) (prepare-state-diff-acc s r1 r2))
		    (else      (prepare-state-same-acc s r1 r2))))))

	 ; Fabrique la fonction de lancement du lexage a l'etat de depart
	 (prepare-start-same
	  (lambda (s1 s2)
	    (let ((peek-char    IS-peek-char)
		  (eof-action   #f)
		  (start-state  #f)
		  (error-action #f))
	      (let ((result
		     (lambda ()
		       (if (not (peek-char))
			   eof-action
			   (start-state error-action))))
		    (hook
		     (lambda ()
		       (set! eof-action   <<EOF>>-action)
		       (set! start-state  (vector-ref states s1))
		       (set! error-action <<ERROR>>-action))))
		(add-hook hook)
		result))))
	 (prepare-start-diff
	  (lambda (s1 s2)
	    (let ((peek-char         IS-peek-char)
		  (eof-action        #f)
		  (peek-left-context IS-peek-left-context)
		  (start-state1      #f)
		  (start-state2      #f)
		  (error-action      #f))
	      (let ((result
		     (lambda ()
		       (cond ((not (peek-char))
			      eof-action)
			     ((= (peek-left-context) lexer-integer-newline)
			      (start-state1 error-action))
			     (else
			      (start-state2 error-action)))))
		    (hook
		     (lambda ()
		       (set! eof-action <<EOF>>-action)
		       (set! start-state1 (vector-ref states s1))
		       (set! start-state2 (vector-ref states s2))
		       (set! error-action <<ERROR>>-action))))
		(add-hook hook)
		result))))
	 (prepare-start
	  (lambda ()
	    (let ((s1 table-nl-start)
		  (s2 table-no-nl-start))
	      (if (= s1 s2)
		  (prepare-start-same s1 s2)
		  (prepare-start-diff s1 s2)))))

	 ; Fabrique la fonction principale
	 (prepare-lexer-none
	  (lambda ()
	    (let ((init-lexeme IS-init-lexeme)
		  (start-func  (prepare-start)))
	      (lambda ()
		(init-lexeme)
		((start-func))))))
	 (prepare-lexer-line
	  (lambda ()
	    (let ((init-lexeme    IS-init-lexeme)
		  (get-start-line IS-get-start-line)
		  (start-func     (prepare-start)))
	      (lambda ()
		(init-lexeme)
		(let ((yyline (get-start-line)))
		  ((start-func) yyline))))))
	 (prepare-lexer-all
	  (lambda ()
	    (let ((init-lexeme      IS-init-lexeme)
		  (get-start-line   IS-get-start-line)
		  (get-start-column IS-get-start-column)
		  (get-start-offset IS-get-start-offset)
		  (start-func       (prepare-start)))
	      (lambda ()
		(init-lexeme)
		(let ((yyline   (get-start-line))
		      (yycolumn (get-start-column))
		      (yyoffset (get-start-offset)))
		  ((start-func) yyline yycolumn yyoffset))))))
	 (prepare-lexer
	  (lambda ()
	    (cond ((eq? counters-type 'none) (prepare-lexer-none))
		  ((eq? counters-type 'line) (prepare-lexer-line))
		  ((eq? counters-type 'all)  (prepare-lexer-all))))))

      ; Calculer la valeur de <<EOF>>-action et de <<ERROR>>-action
      (set! <<EOF>>-action   (prepare-special-action <<EOF>>-pre-action))
      (set! <<ERROR>>-action (prepare-special-action <<ERROR>>-pre-action))

      ; Calculer la valeur de rules-actions
      (let* ((len (quotient (vector-length rules-pre-actions) 2))
	     (v (make-vector len)))
	(let loop ((r (- len 1)))
	  (if (< r 0)
	      (set! rules-actions v)
	      (let* ((yytext? (vector-ref rules-pre-actions (* 2 r)))
		     (pre-action (vector-ref rules-pre-actions (+ (* 2 r) 1)))
		     (action (if yytext?
				 (prepare-action-yytext    pre-action)
				 (prepare-action-no-yytext pre-action))))
		(vector-set! v r action)
		(loop (- r 1))))))

      ; Calculer la valeur de states
      (let* ((len (vector-length trees-v))
	     (v (make-vector len)))
	(let loop ((s (- len 1)))
	  (if (< s 0)
	      (set! states v)
	      (begin
		(vector-set! v s (prepare-state s))
		(loop (- s 1))))))

      ; Calculer la valeur de final-lexer
      (set! final-lexer (prepare-lexer))

      ; Executer les hooks
      (apply-hooks)

      ; Resultat
      final-lexer)))

; Fabrication de lexer a partir de listes de caracteres taggees
(define lexer-make-char-lexer
  (let* ((char->class
	  (lambda (c)
	    (let ((n (char->integer c)))
	      (list (cons n n)))))
	 (merge-sort
	  (lambda (l combine zero-elt)
	    (if (null? l)
		zero-elt
		(let loop1 ((l l))
		  (if (null? (cdr l))
		      (car l)
		      (loop1
		       (let loop2 ((l l))
			 (cond ((null? l)
				l)
			       ((null? (cdr l))
				l)
			       (else
				(cons (combine (car l) (cadr l))
				      (loop2 (cddr l))))))))))))
	 (finite-class-union
	  (lambda (c1 c2)
	    (let loop ((c1 c1) (c2 c2) (u '()))
	      (if (null? c1)
		  (if (null? c2)
		      (reverse u)
		      (loop c1 (cdr c2) (cons (car c2) u)))
		  (if (null? c2)
		      (loop (cdr c1) c2 (cons (car c1) u))
		      (let* ((r1 (car c1))
			     (r2 (car c2))
			     (r1start (car r1))
			     (r1end (cdr r1))
			     (r2start (car r2))
			     (r2end (cdr r2)))
			(if (<= r1start r2start)
			    (cond ((< (+ r1end 1) r2start)
				   (loop (cdr c1) c2 (cons r1 u)))
				  ((<= r1end r2end)
				   (loop (cdr c1)
					 (cons (cons r1start r2end) (cdr c2))
					 u))
				  (else
				   (loop c1 (cdr c2) u)))
			    (cond ((> r1start (+ r2end 1))
				   (loop c1 (cdr c2) (cons r2 u)))
				  ((>= r1end r2end)
				   (loop (cons (cons r2start r1end) (cdr c1))
					 (cdr c2)
					 u))
				  (else
				   (loop (cdr c1) c2 u))))))))))
	 (char-list->class
	  (lambda (cl)
	    (let ((classes (map char->class cl)))
	      (merge-sort classes finite-class-union '()))))
	 (class-<
	  (lambda (b1 b2)
	    (cond ((eq? b1 'inf+) #f)
		  ((eq? b2 'inf-) #f)
		  ((eq? b1 'inf-) #t)
		  ((eq? b2 'inf+) #t)
		  (else (< b1 b2)))))
	 (finite-class-compl
	  (lambda (c)
	    (let loop ((c c) (start 'inf-))
	      (if (null? c)
		  (list (cons start 'inf+))
		  (let* ((r (car c))
			 (rstart (car r))
			 (rend (cdr r)))
		    (if (class-< start rstart)
			(cons (cons start (- rstart 1))
			      (loop c rstart))
			(loop (cdr c) (+ rend 1))))))))
	 (tagged-chars->class
	  (lambda (tcl)
	    (let* ((inverse? (car tcl))
		   (cl (cdr tcl))
		   (class-tmp (char-list->class cl)))
	      (if inverse? (finite-class-compl class-tmp) class-tmp))))
	 (charc->arc
	  (lambda (charc)
	    (let* ((tcl (car charc))
		   (dest (cdr charc))
		   (class (tagged-chars->class tcl)))
	      (cons class dest))))
	 (arc->sharcs
	  (lambda (arc)
	    (let* ((range-l (car arc))
		   (dest (cdr arc))
		   (op (lambda (range) (cons range dest))))
	      (map op range-l))))
	 (class-<=
	  (lambda (b1 b2)
	    (cond ((eq? b1 'inf-) #t)
		  ((eq? b2 'inf+) #t)
		  ((eq? b1 'inf+) #f)
		  ((eq? b2 'inf-) #f)
		  (else (<= b1 b2)))))
	 (sharc-<=
	  (lambda (sharc1 sharc2)
	    (class-<= (caar sharc1) (caar sharc2))))
	 (merge-sharcs
	  (lambda (l1 l2)
	    (let loop ((l1 l1) (l2 l2))
	      (cond ((null? l1)
		     l2)
		    ((null? l2)
		     l1)
		    (else
		     (let ((sharc1 (car l1))
			   (sharc2 (car l2)))
		       (if (sharc-<= sharc1 sharc2)
			   (cons sharc1 (loop (cdr l1) l2))
			   (cons sharc2 (loop l1 (cdr l2))))))))))
	 (class-= eqv?)
	 (fill-error
	  (lambda (sharcs)
	    (let loop ((sharcs sharcs) (start 'inf-))
	      (cond ((class-= start 'inf+)
		     '())
		    ((null? sharcs)
		     (cons (cons (cons start 'inf+) 'err)
			   (loop sharcs 'inf+)))
		    (else
		     (let* ((sharc (car sharcs))
			    (h (caar sharc))
			    (t (cdar sharc)))
		       (if (class-< start h)
			   (cons (cons (cons start (- h 1)) 'err)
				 (loop sharcs h))
			   (cons sharc (loop (cdr sharcs)
					     (if (class-= t 'inf+)
						 'inf+
						 (+ t 1)))))))))))
	 (charcs->tree
	  (lambda (charcs)
	    (let* ((op (lambda (charc) (arc->sharcs (charc->arc charc))))
		   (sharcs-l (map op charcs))
		   (sorted-sharcs (merge-sort sharcs-l merge-sharcs '()))
		   (full-sharcs (fill-error sorted-sharcs))
		   (op (lambda (sharc) (cons (caar sharc) (cdr sharc))))
		   (table (list->vector (map op full-sharcs))))
	      (let loop ((left 0) (right (- (vector-length table) 1)))
		(if (= left right)
		    (cdr (vector-ref table left))
		    (let ((mid (quotient (+ left right 1) 2)))
		      (if (and (= (+ left 2) right)
			       (= (+ (car (vector-ref table mid)) 1)
				  (car (vector-ref table right)))
			       (eqv? (cdr (vector-ref table left))
				     (cdr (vector-ref table right))))
			  (list '=
				(car (vector-ref table mid))
				(cdr (vector-ref table mid))
				(cdr (vector-ref table left)))
			  (list (car (vector-ref table mid))
				(loop left (- mid 1))
				(loop mid right))))))))))
    (lambda (tables IS)
      (let ((counters         (vector-ref tables 0))
	    (<<EOF>>-action   (vector-ref tables 1))
	    (<<ERROR>>-action (vector-ref tables 2))
	    (rules-actions    (vector-ref tables 3))
	    (nl-start         (vector-ref tables 5))
	    (no-nl-start      (vector-ref tables 6))
	    (charcs-v         (vector-ref tables 7))
	    (acc-v            (vector-ref tables 8)))
	(let* ((len (vector-length charcs-v))
	       (v (make-vector len)))
	  (let loop ((i (- len 1)))
	    (if (>= i 0)
		(begin
		  (vector-set! v i (charcs->tree (vector-ref charcs-v i)))
		  (loop (- i 1)))
		(lexer-make-tree-lexer
		 (vector counters
			 <<EOF>>-action
			 <<ERROR>>-action
			 rules-actions
			 'decision-trees
			 nl-start
			 no-nl-start
			 v
			 acc-v)
		 IS))))))))

; Fabrication d'un lexer a partir de code pre-genere
(define lexer-make-code-lexer
  (lambda (tables IS)
    (let ((<<EOF>>-pre-action   (vector-ref tables 1))
	  (<<ERROR>>-pre-action (vector-ref tables 2))
	  (rules-pre-action     (vector-ref tables 3))
	  (code                 (vector-ref tables 5)))
      (code <<EOF>>-pre-action <<ERROR>>-pre-action rules-pre-action IS))))

(define lexer-make-lexer
  (lambda (tables IS)
    (let ((automaton-type (vector-ref tables 4)))
      (cond ((eq? automaton-type 'decision-trees)
	     (lexer-make-tree-lexer tables IS))
	    ((eq? automaton-type 'tagged-chars-lists)
	     (lexer-make-char-lexer tables IS))
	    ((eq? automaton-type 'code)
	     (lexer-make-code-lexer tables IS))))))

;
; Table generated from the file twiki.l by SILex 1.0
;

(define lexer-default-table
  (vector
   'line
   (lambda (yycontinue yygetc yyungetc)
     (lambda (yytext yyline)
                                (list 'end-of-input #f ) ;; yyline)
       ))
   (lambda (yycontinue yygetc yyungetc)
     (lambda (yytext yyline)
                                (lex-error (conc yyline " : illegal character ") (yygetc))
       ))
   (vector
    #t
    (lambda (yycontinue yygetc yyungetc)
      (lambda (yytext yyline)
                                (list 'opensq     yytext)
        ))
    #t
    (lambda (yycontinue yygetc yyungetc)
      (lambda (yytext yyline)
                                (list 'closesq    yytext)
        ))
    #t
    (lambda (yycontinue yygetc yyungetc)
      (lambda (yytext yyline)
                                (list 'opensquig  yytext)
        ))
    #t
    (lambda (yycontinue yygetc yyungetc)
      (lambda (yytext yyline)
                                (list 'closesquig yytext)
        ))
    #t
    (lambda (yycontinue yygetc yyungetc)
      (lambda (yytext yyline)
                                (list 'bang       yytext)
        ))
    #t
    (lambda (yycontinue yygetc yyungetc)
      (lambda (yytext yyline)
                                (list 'plaintext  yytext)
        )))
   'decision-trees
   0
   0
   '#((59 (35 (32 (9 err (11 1 err)) (33 1 (34 2 err))) (38 (= 36 err 1)
    (44 (39 err 1) (45 err 1)))) (95 (92 (65 err (91 1 6)) (93 1 (94 5
    err))) (123 (= 96 err 1) (125 (124 4 err) (126 3 err))))) (44 (35 (11
    (9 err 1) (= 32 1 err)) (37 (36 1 err) (= 38 err 1))) (92 (59 (45 err
    1) (65 err (91 1 err))) (96 (93 1 (95 err 1)) (97 err (123 1 err)))))
    err err err err err)
   '#((#f . #f) (5 . 5) (4 . 4) (3 . 3) (2 . 2) (1 . 1) (0 . 0))))

;
; User functions
;

(define lexer #f)

(define lexer-get-line   #f)
(define lexer-getc       #f)
(define lexer-ungetc     #f)

(define lexer-init
  (lambda (input-type input)
    (let ((IS (lexer-make-IS input-type input 'line)))
      (set! lexer (lexer-make-lexer lexer-default-table IS))
      (set! lexer-get-line   (lexer-get-func-line IS))
      (set! lexer-getc       (lexer-get-func-getc IS))
      (set! lexer-ungetc     (lexer-get-func-ungetc IS)))))








Added stml2/modules/twiki/twiki.scm version [d0b51a85fd].








































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; twiki module
(require-extension silex sqlite3 regex posix)

(include "twiki.l.scm")

(define (twiki:open-db keys)
  (let* ((fname   (twiki:keys->fname keys))
	 (fexists (file-exists? fname))
	 (db (dbi:open 'sqlite3 '((dbname . fname)))))
    (if (not fexists)
	(for-each 
	 (lambda (sqry)
	   (dbi:exec db sqry))
	 '("CREATE TABLE dats     (id INTEGER PRIMARY KEY,md5sum TEXT,dat BLOB,type INTEGER);"
	   "CREATE TABLE tiddlers (id INTEGER PRIMARY KEY,wiki_id INTEGER,name TEXT,rev INTEGER,dat_id INTEGER,created_on INTEGER,changed_on INTEGER,owner_id INTEGER);"
	   "CREATE TABLE revs     (id INTEGER PRIMARY KEY,tag TEXT);"
	   "CREATE TABLE wikis    (id INTEGER PRIMARY KEY,key_name TEXT,title TEXT,created_on INTEGER);")))
    (sqlite3:set-busy-timeout!(dbi:db-conn db) 1000000)
    db))
	
(define (twiki:view)
  (s:div 'class "node"
  (s:h1 "Twiki")
  "Title, pictures, etc."
   (let ()
     "blah")))


(define (twiki:wiki . keys)
  (let ((key (conc keys)))
    (twiki:view)))

(define (twiki:extract-tiddlers dat)
  (let* ((inp (open-input-string dat))
	 (prev-state #f)
	 (stack      (list 'start))
	 (links      '())
	 (currlnk    #f))
    (lexer-init 'port inp)
    (let loop ((token          (lexer)))
      (let ((token-type (car token))
	    (token-val  (cadr token))
	    (state      (car  stack)))
	(if (not (eq? prev-state state))
	    (begin
	      (print "state: " state)
	      (set! prev-state state)))
	(case token-type
	  ('end-of-input       (print "Done")(close-input-port inp))
	  ('twikilink-start
	   (set! stack (cons 'twikilink-start stack))
	   (loop (lexer)))
	  ('twikilink-end
	   (set! links (cons currlnk links))
	   (set! stack (cdr stack))
	   (loop (lexer)))
	  ('twikitext
	   (if (eq? state 'twikilink-start)
	       (set! currlnk (cadr token))
	       (print "Got " token))
	   (loop (lexer)))
	  ('anydat
	   (loop (lexer)))
	  (else
	   (print "ERROR: unknown token " token " on line " (lexer-get-line))
	   (loop (lexer))))))
    links))
     








Added stml2/modules/twiki/twikiparser.scm version [cc34f7c51f].













































































































































































































































































































































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
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
227
228
229
230
231
232
233
234
235
236
237
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
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+


(require-extension sqlite3 regex posix eformat silex stack regex)

(define help "
Usage: nldb [options]


General
  -h                      : this help

Netlist data queries

  -findpath start,end     : find path from start to end. % is a wildcard

Managing netlist data

  -load /path/to/netlist  : load a model into the db
  -d dbname               : name of the .db file
  -dump fname             : dump the netlist in to verilog file

")

(include "/nfs/an/home/mrwellan/stuff/tools/lnkmkr/args.scm")
(include "verilog.l.scm")

;; process args
(define remargs (get-args (argv)
			  (list "-load"
				"-d"          "-dump" 
				"-findpath")
			  
			  (list "-h"
				)
			  arg-hash
			  0)) ;;

(define dbpaths (list "testing.db"))

(define dbpath #f)

(if (get-arg "-d")
    (set! dbpath (get-arg "-d"))
    (for-each
     (lambda (path)
       (if (file-exists? path)
	   (set! dbpath path)))
     dbpaths))

(if (and (not dbpath) (get-arg "-d"))
    (begin
      (print "Can't find db. " (get-arg "-d") " Try again or contact Matt!")
      (exit 1)))

(define dbexists (file-exists? dbpath))

(define realuser (getenv "USER"))
(define user realuser)

(define db (sqlite3:open dbpath))
(sqlite3:set-busy-timeout! db 1000000)

(define (mk-tables)
  (for-each
   (lambda (sqlstmt)
     (sqlite3:exec db sqlstmt))
   (list "CREATE TABLE modules(id INTEGER PRIMARY KEY,name_id INTEGER);"
	 "CREATE TABLE nets   (id INTEGER PRIMARY KEY,name_id INTEGER,module_id INTEGER);"
	 "CREATE TABLE insts  (id INTEGER PRIMARY KEY,name_id INTEGER,module_id INTEGER,parent_id INTEGER);"
	 "CREATE TABLE pins   (id INTEGER PRIMARY KEY,name_id INTEGER,module_id INTEGER,net_id INTEGER,type_id INTEGER);"
	 "CREATE TABLE conns  (id INTEGER PRIMARY KEY,net_id  INTEGER,inst_id INTEGER,pin_id INTEGER);"
	 "CREATE TABLE names  (id INTEGER PRIMARY KEY,name TEXT);"
	 "CREATE TABLE types(id INTEGER PRIMARY KEY,type TEXT);"
	 "INSERT INTO types VALUES(1, 'undef');"
	 "INSERT INTO types VALUES(2, 'input');"
	 "INSERT INTO types VALUES(3, 'output');"
	 "INSERT INTO types VALUES(4, 'inout');"
	 "INSERT INTO types VALUES(5, 'pwr');"
	 "PRAGMA synchronous=OFF;")))

(if (not dbexists)(mk-tables))

;;======================================================================
;; NETLIST READING
;;======================================================================

;; Use a stack to tracking state
;;
(define nldb:*stack* (make-stack))

(define (nldb:read-files fnames) ;; read in a list of files
  (for-each 
   (lambda (fname)
     (if (file-exists? fname)
	 (nldb:read-file fname)))
   fnames))

;;======================================================================
;; PRECOMPILED REGEXS
;;======================================================================

(define nldb:escaped-name     (regexp "^\\s*\\\\([^\\s]+)\\s*"))
(define nldb:trailing-garbage (regexp "^\\s*([^\\s,;]+)[,;\\s]*$"))
(define nldb:module-pin       (regexp "^\\s*([^\\s]+)\\s*([,\\s\\)]*)"))
(define nldb:pins-end         (regexp "\\)\\s*;"))
(define nldb:input-output     (regexp "\\s*(input|output)\\s+([^\\s]+)[\\s;,]"))

;;                                           modname instname( .\pinname[35] (\netname ),
(define nldb:instance         (regexp "^\\s*([^\\s]+)\\s+([^\\s]+)\\s*\\(\\s*\\.([^\\s]+)\\s*\\(\\s*([^\\s]+)\\s*\\)\\s*,"))
(define nldb:inst-conn        (regexp "^\\s*\\.([^\\s]+)\\s*\\(\\s*([^\\s])+\\s+\\)\\s*([\\),;]+)"))

;;                                                 module_name         netname (opt)
(define nldb:module-regex (regexp "^\\s*module\\s+([^\\s]+)\\s*\\(\\s*([^\\s,]+\\s*,|)$"))

;;======================================================================
;; MISC
;;======================================================================

;; apply regex and set nldb:match-val
(define nldb:match-val #f)
(define (nldb:regex-match r l)
  (let ((m (string-match r l)))
    (set! nldb:match-val m) m))

;; stmt can only return *one* value!!
(define (nldb:sqlite3:get-one stmt . params)
  (let ((sqlstmt (sqlite3:prepare db stmt))
	(result  #f))
    (apply sqlite3:for-each-row
	   (lambda (x)
	     (set! result x)) sqlstmt params)
    (sqlite3:finalize! sqlstmt)
    result))

;;======================================================================
;; CACHE
;;======================================================================

(define *cache*             (make-hash-table))
(define *module-name-cache* (make-hash-table))

(define (cache-get-module-hash module)
  (sub-hash-create-get *cache* module))

(define (sub-hash-create-get subhash key)
  (let ((shash (hash-table-get/default subhash key)))
    (if shash shash
	(let ((newh (make-hash-table)))
	  (hash-table-set! subhash key newh)
	  newh))))

;; (cache-set! "abc_adder" 'pin "addrin" 0)
(define (cache-set! module objtype objname value)
  (let* ((mhash (cache-get-module-hash module))
	 (thash (sub-hash-create-get mhash objtype)))
    (hash-table-set! thash objname value)))

(define (cache-ref module objtype objname)
  (let ((mhash (hash-table-ref/default *cache* module)))
    (if mhash
	(let ((ohash (hash-table-ref/default mhash objtype)))
	  (if ohash
	      (hash-table-ref/default ohash objname)
	      #f))
	#f)))
    
;;======================================================================
;; NAMES
;;======================================================================

(define nldb:names-hash (make-hash-table))

;; always sucessful. inserts name if not found
(define (nldb:get-name-id name)
  (let ((cached-id (hash-table-ref/default nldb:names-hash name #f)))
    (if cached-id cached-id
	(let ((id (nldb:sqlite3:get-one "SELECT id FROM names WHERE name=?;" name)))
	  (if id
	      (begin
		(hash-table-set! nldb:names-hash name id )
		id)
	      (begin
		(sqlite3:exec db "INSERT INTO names (name) VALUES (?);" name)
		(nldb:get-name-id name)))))))

(define (nldb:clean-name name)
  (if (nldb:regex-match nldb:escaped-name name) ;; process escaped identifiers
      (list-ref nldb:match-val 1)
      (if (nldb:regex-match nldb:trailing-garbage name)
	  (list-ref nldb:match-val 1)
	  name)))

;;======================================================================
;; MODULES
;;======================================================================

;; add a module and return its id.
(define (nldb:get-module-id name-id)
  (let ((id  (nldb:sqlite3:get-one 
	      "SELECT id FROM modules WHERE name_id=?;" name-id)))
    (if id id
	(begin
	  (nldb:insert-module name-id)
	  (nldb:get-module-id name-id))))) ;; now retrieve and return the id

;; not safe to use outside of get-module-id - could add duplicates
(define (nldb:insert-module name-id)
  (sqlite3:exec db "INSERT INTO modules (name_id) VALUES (?);" name-id))

;; module namespace is unique so this is ok, should check for redefining though.
(define (nldb:get-module-by-name name)
  (let ((module-id (hash-table-ref *module-name-cache* name)))
    (if module-id module-id
	(let ((mid (nldb:get-module-id (nldb:get-name-id name))))
	  (hash-table-set! *module-name-cache* name mid)))))

;;======================================================================
;; PINS
;;======================================================================

(define (nldb:get-pin-id module-id name-id)
  (nldb:sqlite3:get-one 
   (string-append "SELECT id FROM pins WHERE module_id=? AND name_id=?;") 
   module-id name-id))

(define (nldb:add-pin module-id name-id type-id)
  (let ((pin-id (nldb:get-pin-id module-id name-id)))
    (if pin-id pin-id
	(begin	
	  (nldb:insert-pin module-id name-id type-id)
	  (nldb:get-pin-id module-id name-id)))))

(define (nldb:insert-pin module-id name-id type-id)
  (sqlite3:exec db "INSERT INTO pins (module_id,name_id,type_id) VALUES (?,?,?);"
		module-id name-id (if type-id type-id 0)))

(define (nldb:set-pin-direction pin-id direction)
  (sqlite3:exec db "UPDATE pins SET type_id=(SELECT id FROM types WHERE type=?) WHERE id=?;" direction pin-id))

(define (nldb:set-pin-net pin-id net-id)
  (sqlite3:exec db "UPDATE pins SET net_id=? WHERE id=?;" net-id pin-id))

;;====================================================================
;; CONNS
;;======================================================================

(define (nldb:get-conn-id inst-id pin-id)
  ;; (if (not (and inst-id pin-id))(print "ERROR: nldb:get-conn-id called with bad params: inst-id " inst-id " pin-id " pin-id)
  (nldb:sqlite3:get-one  "SELECT id FROM conns WHERE inst_id=? AND pin_id=?;" inst-id pin-id))

(define (nldb:add-conn inst-id pin-id net-id)
  ;;  (if (not (and inst-id pin-id net-id))(print "ERROR: nldb:add-conn called with bad params: inst-id " inst-id " pin-id " pin-id " net-id " net-id)
  (let ((conn-id (nldb:get-conn-id inst-id pin-id)))
    (if conn-id conn-id
	(begin	
	  (nldb:insert-conn inst-id pin-id net-id)
	  (nldb:get-conn-id inst-id pin-id)))))

(define (nldb:insert-conn inst-id pin-id net-id)
  ;;  (if (not (and inst-id pin-id net-id))(print "ERROR: nldb:insert-conn called with bad params: inst-id " inst-id " pin-id " pin-id " net-id " net-id)
  (sqlite3:exec db "INSERT INTO conns (inst_id,pin_id,net_id) VALUES (?,?,?);"
		inst-id pin-id net-id ))

;;======================================================================
;; NET
;;======================================================================

(define (nldb:get-net-id module-id name-id)
  (nldb:sqlite3:get-one "SELECT id FROM nets WHERE name_id=?;" name-id))

(define (nldb:add-net module-id name-id)
  (let ((net-id (nldb:get-net-id module-id name-id)))
    (if net-id net-id
	(begin
	  (nldb:insert-net module-id name-id)
	  (nldb:get-net-id module-id name-id)))))

(define (nldb:insert-net module-id name-id)
  (sqlite3:exec db "INSERT INTO nets (module_id,name_id) VALUES(?,?);" module-id name-id))

;;======================================================================
;; INSTANCES
;;======================================================================

(define (nldb:get-inst-id parent-id name-id)
  (nldb:sqlite3:get-one "SELECT id FROM insts WHERE parent_id=? AND name_id=?;" parent-id name-id))

;; sub-mod-id = type of instance, parent-id = where instantiated
(define (nldb:add-inst module-id parent-id name-id)
  (let ((inst-id (nldb:get-inst-id parent-id name-id))) ;; parent and name are enough to identify it
    (if inst-id inst-id
	(begin
	  (nldb:insert-inst module-id parent-id name-id)
	  (nldb:get-inst-id parent-id name-id)))))

(define (nldb:insert-inst module-id parent-id name-id)
  (sqlite3:exec db "INSERT INTO insts (module_id,parent_id,name_id) VALUES(?,?,?);" module-id parent-id name-id))

;;======================================================================
;; RECORD FOR STATE
;;======================================================================

(define *statevec* (make-vector 5))

(define-inline (curr-pin-id)           (vector-ref  *statevec* 0))
(define-inline (curr-inst-id)          (vector-ref  *statevec* 1))
(define-inline (curr-module-id)        (vector-ref  *statevec* 2))
(define-inline (curr-inst-module-id)   (vector-ref  *statevec* 3))

(define-inline (set-curr-pin-id!         id)(vector-set! *statevec* 0 id))
(define-inline (set-curr-inst-id!        id)(vector-set! *statevec* 1 id))
(define-inline (set-curr-module-id!      id)(vector-set! *statevec* 2 id))
(define-inline (set-curr-inst-module-id! id)(vector-set! *statevec* 3 id))

;;======================================================================
;; FILE I/O
;;======================================================================

;; Initialization and support routines for nldb:read-file
(stack-push! nldb:*stack* 'start)
(define nldb:esc-regex  (regexp "^\\\\([^\\s]*)\\s*$") )
(define (nldb:clean-identifier token)
  (let* ((t   (car token))
	 (v   (cadr token))
	 (ctm (string-match nldb:esc-regex v)))
    (list 'identifier (list-ref ctm 1))))


(define (nldb:read-file fname)
  (let* ((inp (open-input-file fname))
	 (prev-state #f))
    (lexer-init 'port inp)
    (let loop ((token          (lexer)))
      (let ((token-type (car token))
	    (token-val  (cadr token))
	    (state      (stack-peek herc:*stack*)))
	(if (not (eq? prev-state state))
	    (begin
	      (print "state: " state)
	      (set! prev-state state)))
	(case token-type
	  ('end-of-input       (print "Done")(close-input-port inp))
	  ('whitespace         (loop (lexer)))  ;; skip whitespace
	  ('comment-begin      
	   (stack-push! herc:*stack* 'comment )
	   (loop (lexer)))
	  ('comment-end        (stack-pop! herc:*stack*)(loop (lexer)))
	  ('begin              (stack-push! herc:*stack* 'begin)(loop (lexer)))
	  ('end                (stack-pop! herc:*stack*)(loop (lexer)))
	  ('cell
	   (case state
	     ('begin
	       (stack-push! herc:*stack* 'cell-name)
	       (loop (lexer)))
	     (else
	      (loop (lexer)))))
	  ('plainidentifier
	   (case state
	     ('cell-name

	  ('statementend       (stack-pop! nldb:*stack*)(loop (lexer)))
	  ('endparen           (stack-pop! nldb:*stack*)(loop (lexer)))
	  ('endmodule          (stack-pop! nldb:*stack*)(loop (lexer)))

	  ('startparen 
	   (case state
	     ('module-pins     (loop (lexer)))
	     ('inst-def        (loop (lexer)))
	     ('inst-conn-def   (loop (lexer)))
	     ('pin-net         (loop (lexer)))
	     (else             (print "ERROR: Didn't expect an open paren here! Line " (lexer-get-line)))))

	  ('comma
	   (case state
	     ('module-pins     (loop (lexer)))
	     ('input-pin       (loop (lexer)))
	     ('output-pin      (loop (lexer)))
	     ('wire            (loop (lexer)))
	     ('inst-conn-def   (loop (lexer))) ;; (stack-pop! nldb:*stack*) (loop (lexer)))
	     (else             (print "ERROR: Didn't expect a comma here! Line " (lexer-get-line)))))

	  ('module 
	   (case state
	     ('start 
	      (stack-push! nldb:*stack* 'module)      ;; we will be in a module
	      (stack-push! nldb:*stack* 'module-def)) ;; starting in the def
	     (else
	      (print "ERROR: Didn't expect module declaration here! Line " (lexer-get-line))))
	   (loop (lexer)))

	  ('input 
	   (case state
	     ('module      (stack-push! nldb:*stack* 'input-pin))
	     (else         (print "ERROR: Didn't expect \"input\" statement here! Linenum " (lexer-get-line))))
	   (loop (lexer)))

	  ('output
	   (case state
	     ('module      (stack-push! nldb:*stack* 'output-pin))
	     (else         (print "ERROR: Didn't expect \"output\" statement here! Linenum " (lexer-get-line))))
	   (loop (lexer)))
	  
	  ('inout
	   (case state
	     ('module      (stack-push! nldb:*stack* 'inout-pin))
	     (else         (print "ERROR: Didn't expect \"inout\" statement here! Linenum " (lexer-get-line))))
	   (loop (lexer)))

	  ('pin 
	   (case state
	     ('inst-conn-def
	      (let* ((pin-name    (substring token-val 1 (string-length token-val)))
		     (pin-name-id (nldb:get-name-id pin-name))
		     (pin-id      (nldb:add-pin (curr-module-id) pin-name-id #f)))
		(stack-push! nldb:*stack* 'pin-net)
		(set-curr-pin-id! pin-id)
		(loop (lexer))))
	     (else  (print "ERROR: Didn't expect pin here " token-val " Linenum: " (lexer-get-line)))))

	  ('identifier
	   (case state
	     ('module  ;; this must be an instance, an identifier at the top level
	      (let* ((inst-mod-id (nldb:get-module-by-name token-val)))
		(set-curr-inst-module-id! inst-mod-id)
		(stack-push! nldb:*stack* 'inst-def))
	      (loop (lexer)))
	     ('inst-def                  ;;     inst-module type  parent-id    inst-name-id
	      (let* ((inst-id (nldb:add-inst (curr-inst-module-id)(curr-module-id)(nldb:get-name-id token-val))))
		(set-curr-inst-id! inst-id))
	      (stack-push! nldb:*stack* 'inst-conn-def)
	      (loop (lexer)))
	     ('module-def
	      (let* ((m-id (nldb:get-module-by-name token-val)))
		(set-curr-module-id! m-id))
	      (stack-push! nldb:*stack* 'module-pins))
	     ('module-pins
	      (nldb:add-pin (curr-module-id) (nldb:get-name-id token-val) #f))
	     ('input-pin
	      (let ((pin-id (nldb:get-pin-id (curr-module-id) (nldb:get-name-id token-val))))
		(nldb:set-pin-direction pin-id "input")))
	     ('output-pin
	      (let ((pin-id (nldb:get-pin-id (curr-module-id) (nldb:get-name-id token-val))))
		(nldb:set-pin-direction pin-id "output")))
	     ('inout-pin
	      (let ((pin-id (nldb:get-pin-id (curr-module-id) (nldb:get-name-id token-val))))
		(nldb:set-pin-direction pin-id "inout")))
	     ('pin-net
	      (let* ((net-name-id (nldb:get-name-id token-val))
		     (net-id      (nldb:add-net (curr-inst-module-id) net-name-id)))
		(nldb:add-conn (curr-inst-id) (curr-pin-id) net-id)))
	     (else
	      (print "ERROR: Didn't expect an identifier here! Token " token-val " Line " (lexer-get-line))))
	   (loop (lexer)))

	  (else
	   (print "ERROR: unknown token " token " on line " (lexer-get-line))
	   (loop (lexer))))))))
     








Added stml2/requirements.scm.template version [b71aaa144e].




















1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; choose your db interface as appropriate
(require-extension sqlite3)
(import (prefix sqlite3 sqlite3:))

;; (require-extension postgresql)
;; (import (prefix postgresql pg:))

;; (require-extension cgi-util)
;; (require-extension cookie)
(use posix)
;; (require-extension proplist)
(use regex)
(use srfi-1) 
;; (require-extension tinyclos)
(use srfi-69)
(use data-structures)








Added stml2/rollup-pages.scm version [b24bc2e231].





















































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

(use 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\")"))
  (if (hash-table-ref/default lookup (conc page "_view") #f)
      (print "(include \"pages/" page "_view.scm\")"))
  (print ")\n"))

(let* ((views  (glob "pages/*_view.scm"))
       (ctrls  (glob "pages/*_ctrl.scm"))
       (all    (append views ctrls))
       (lookup (make-hash-table))
       (pages  (delete-duplicates
		(map (lambda (x)
		       (let* ((res  (string-match extract-rx x))
			      (page (cadr res))
			      (type (caddr res)))
			 (hash-table-set! lookup (conc page "_" type) #t)
			 (cadr res)))
		     all))))
  (if (null? all)(begin (print "No page files matching pages/*_(view|ctrl).scm")(exit)))
  (print "Pages: " pages)
  ;; first the individual rollup wrappers (used by the dynamic load)
  (for-each 
   (lambda (page)
     (let ((pagefile  (conc "pages/" page ".scm")))
       (print "page " page " ")
       (if (not (file-exists? pagefile))
	   (begin
	     (with-output-to-file pagefile
	       (lambda ()
		 (print-page-wrapper lookup page)))
	     (print " created"))
	   (print " already created"))))
   pages)
  ;; then the monolithic rollup wrapper (used in compiling the single-executable)
  (with-output-to-file "all_pages.scm"
    (lambda ()
      (for-each
       (lambda (page)
	 (print-page-wrapper lookup page))
       pages))))


  








Added stml2/session.scm version [300e7014a0].
























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.

;; (declare (unit session))
(module session
    *
  
(import chicken scheme data-structures extras srfi-13 ports posix files srfi-1)

(use (prefix dbi dbi:) srfi-69)
(require-extension regex)
(use cookie stmlcommon) ;; (declare (uses cookie))

)








Added stml2/sessions.sql version [051fddcb13].









1
2
3
4
5

+
+
+
+
+

CREATE TABLE session_vars (id integer primary key,  session_id integer, page text, key text, value text);

CREATE TABLE sessions ( id integer primary key, session_key text); 
	









Added stml2/setup.scm version [27fec5f813].

























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.

(module setup
    *
(import chicken scheme data-structures extras srfi-13 ports posix)

(uses session misc-stml)
;; (declare (unit setup))se
;; (declare (uses session))
(require-extension srfi-69)
(require-extension regex)


)








Added stml2/spiffyserver.scm version [0953505b2d].

















1
2
3
4
5
6
7
8
9
10
11
12
13

+
+
+
+
+
+
+
+
+
+
+
+
+

;; This doesn't work yet
;;
(use spiffy cgi-handler)

(spiffy-debug-mode #t)

(spiffy-file-ext-handlers 
 `(("drcdb" . ,(cgi-handler* "/path/to/drcdb"))))

(spiffy-root-path "/path/to/web")

(start-server location: (get-host-name)
                init: noop)








Added stml2/sqlite3.scm version [935dbe7787].


























































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; 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)

(define args (argv))
(define num-args (length args))

(define dbname #f)
(define cmd    #f)

(if (> num-args 1)
  (set! dbname (cadr args))
  (exit 0))

(if (> num-args 2)
  (set! cmd (caddr args)))

(define db (sqlite3:open dbname))

(define (interactive db)
  (let ((prompt " > "))
    (display prompt)
  (let loop ((cmd (read-line)))
    (cond 
      ((> (string-length cmd) 0)
       (process-cmd db cmd)
       (display prompt)
       (loop (read-line)))
      (else
	(loop (read-line)))))))
 
(define (process-cmd db cmd)
  (sqlite3:for-each-row
    (lambda (a . b)
      (print a " " (string-intersperse b " ")))
    db cmd))

(if cmd
  (process-cmd db cmd)
  (interactive db))

(sqlite3:finalize! db)    









Added stml2/stml.config.template version [007967e3ce].












1
2
3
4
5
6
7
8

+
+
+
+
+
+
+
+

'(sroot   "/path/to/{pages,models}/dir"
  logfile "/tmp/stmlrun/logs.log"
  dbtype  sqlite3
  dbinit   ((dbname   . "test-stml.db")
            (user     . "nobody")
            (password . "Dapassword")
            (host     . "localhost"))
  domain  "192.168.1.150")








Added stml2/stml2.meta version [e8cabdbc79].
























1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

(
; Your egg's license:
(license "LGPL")

; Pick one from the list of categories (see below) for your egg and enter it
; here.
(category misc)

; A list of eggs mpeg3 depends on.  If none, you can omit this declaration
; altogether. If you are making an egg for chicken 3 and you need to use
; procedures from the `files' unit, be sure to include the `files' egg in the
; `needs' section (chicken versions < 3.4.0 don't provide the `files' unit).
; `depends' is an alias to `needs'.
(needs srfi-69)

; A list of eggs required for TESTING ONLY.  See the `Tests' section.
(test-depends test)

(author "Matt Welland")
(synopsis "Primitive argument processor."))








Added stml2/stml2.scm version [ee4c13898d].




































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
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
227
228
229
230
231
232
233
234
235
236
237
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
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
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
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
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
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

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

;; 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 cookie)
(use (prefix dbi dbi:) (prefix crypt c:) typed-records)

;; (declare (uses misc-stml))
(use regex)

;; The (usually global) sdat contains everything about the session
;;
(defstruct sdat
  ;; database
  (dbtype 'pg)
  (dbinit #f)
  (conn   #f)
  ;; page info
  (page "index")
  (page-type 'html)
  (toppage "index")
  (curr-page    "index")
  (content-type "Content-type: text/html; charset=iso-8859-1\n\n")
  ;; forms and variables
  (formdat      #f)
  (params '())
  (path-params '())
  (session-key #f)
  (pagedat     '())
  (alt-page-dat #f)
  (session-cookie #f)
  (pagevars        (make-hash-table))
  (pagevars-before (make-hash-table))
  (sessionvars     (make-hash-table))
  (sessionvars-before (make-hash-table))
  (globalvars      (make-hash-table))
  (globalvars-before (make-hash-table))
  ;; ports and log file
  (curr-err       #f)
  (log-port       (current-error-port))
  (logfile        "/tmp/stml.log")
  (seen-pages     '())
  (page-dir-style  'flat)
  (debug-mode      #f)
  (session-id      #f)
  (request-method  #f)
  (domain          "localhost")
  (twikidir        #f)
  (script          #f)
  (force-ssl       #f)
  (shared-hash     (make-hash-table))
  ;; paths
  (sroot         "./")
  (models        #f)
  (views         #f)
)

(define (sdat-set-if session configdat var settor)
  (let ((val (s:find-param var configdat)))
    (if val (settor session val))))

(define (session:initialize session #!optional (configf #f))
  ;; (let* ((rawconfigdat (session:read-config session configf))
  ;;	 (configdat (if rawconfigdat (eval rawconfigdat) '())))
    ;; (sdat-set-if session configdat 'sroot     sdat-root-set!)
    ;; (sdat-set-if session configdat 'logfile   sdat-logfile-set!)
    ;; (sdat-set-if session configdat 'dbtype    sdat-dbtype-set!)
    ;; (sdat-set-if session configdat 'dbinit    sdat-dbinit-set!)
    ;; (sdat-set-if session configdat 'domain    sdat-domain-set!)
    ;; (sdat-set-if session configdat 'twikidir  sdat-twikidir-set!)
    ;; (sdat-set-if session configdat 'page-dir-style sdat-page-set!)
    ;; (sdat-set-if session configdat 'sroot sdat-root-set!)
    ;; (sdat-set-if session configdat 'sroot sdat-root-set!)
    ;; (sdat-set-if session configdat 'sroot sdat-root-set!)
    ;; following are set always from config
    ;; (sdat-page-dir-style-set! session (s:find-param 'page-dir-style configdat))
  (let* ((rawconfigdat (session:read-config session configf))
	 (configdat (if rawconfigdat (eval rawconfigdat) '()))
	 (sroot     (s:find-param 'sroot    configdat))
	 (models    (s:find-param 'models   configdat))
	 (views     (s:find-param 'views    configdat))
	 (logfile   (s:find-param 'logfile  configdat))
	 (dbtype    (s:find-param 'dbtype   configdat))
	 (dbinit    (s:find-param 'dbinit   configdat))
	 (domain    (s:find-param 'domain   configdat))
	 (twikidir  (s:find-param 'twikidir configdat))
	 (page-dir  (s:find-param 'page-dir-style configdat))
	 (debugmode (or (s:find-param 'debug-mode configdat)(s:find-param 'debugmode configdat)))
         (script    (s:find-param 'script    configdat))
	 (force-ssl (s:find-param 'force-ssl configdat)))
    (if sroot    (sdat-sroot-set!      session sroot))
    (if models   (sdat-models-set!     session models))
    (if views    (sdat-views-set!      session views))
    (if logfile  (sdat-logfile-set!    session logfile))
    (if dbtype   (sdat-dbtype-set!     session dbtype))
    (if dbinit   (sdat-dbinit-set!     session dbinit))
    (if domain   (sdat-domain-set!     session domain))
    (if twikidir (sdat-twikidir-set!   session twikidir))
    (if debugmode (sdat-debug-mode-set! session debugmode))
    (if script    (sdat-script-set!    session script))
    (if force-ssl (sdat-force-ssl-set! session force-ssl))
    (sdat-page-dir-style-set! session page-dir)
    ;; (print "configdat: ")(pp configdat)
    (if debugmode
	(session:log session "sroot: " sroot " logfile: " logfile " dbtype: " dbtype 
		     " dbinit: " dbinit " domain: " domain " page-dir-style: " page-dir))
    ))

;; extract various tokens from the parameter list
;;   'key val => put in the params list
;;   strings  => maintain order and add to the datalist <<== IMPORTANT
(define (s:extract inlst)
  (if (null? inlst) inlst
      (let loop ((data '())
                 (params '())
                 (head (car inlst))
                 (tail (cdr inlst)))
        ;; (print "head=" head " tail=" tail)
        (cond 
         ((null? tail)
          (if (symbol? head) ;; the last item is a param - borked
              (s:log "ERROR: param with no value"))
          (list (append data (list (s:any->string head))) params))
         ((or (string? head)(list? head)(number? head))
          (loop (append data (list  (s:any->string head))) params (car tail)   (cdr tail)))
         ((symbol? head)
          (let ((new-params (cons (list head (car tail)) params))
                (new-tail  (cdr tail)))
            (if (null? new-tail) ;; we are done, no more params etc.
                (list data new-params)
                (loop data new-params (car new-tail)(cdr new-tail)))))
         (else
          (s:log "WARNING: Malformed input, you have broken stml, remember that all stml calls should return a result (null list or empty string is ok):\n  head=" head 
	          "\n  tail=" tail 
                  "\n  inlst=" inlst 
                  "\n  params=" params)
	  (if (null? tail)
	      (list data params)
	      (loop data params (car tail)(cdr tail))))))))

;; most tags can be handled by this routine
(define (s:common-tag tagname args)
  (let* ((inputs (s:extract args))
         (data   (car inputs))
         (params (s:process-params (cadr inputs))))
    (list (conc "<" tagname params ">")
          data
          (conc "</" tagname ">"))))

;; Suggestion: order these alphabetically
(define (s:a      . args) (s:common-tag "A"      args))
(define (s:b      . args) (s:common-tag "B"      args))
(define (s:u      . args) (s:common-tag "U"      args))
(define (s:big    . args) (s:common-tag "BIG"    args))
(define (s:body   . args) (s:common-tag "BODY"   args))
(define (s:button . args) (s:common-tag "BUTTON" args))
(define (s:center . args) (s:common-tag "CENTER" args))
(define (s:code   . args) (s:common-tag "CODE"   args))
(define (s:div    . args) (s:common-tag "DIV"    args))
(define (s:h1     . args) (s:common-tag "H1"     args))
(define (s:h2     . args) (s:common-tag "H2"     args))
(define (s:h3     . args) (s:common-tag "H3"     args))
(define (s:h4     . args) (s:common-tag "H4"     args))
(define (s:h5     . args) (s:common-tag "H5"     args))
(define (s:head   . args) (s:common-tag "HEAD"   args))
(define (s:html   . args) (s:common-tag "HTML"   args))
(define (s:i      . args) (s:common-tag "I"      args))
(define (s:img    . args) (s:common-tag "IMG"    args))
(define (s:input  . args) (s:common-tag "INPUT"  args))
(define (s:output . args) (s:common-tag "OUTPUT" args))
(define (s:link   . args) (s:common-tag "LINK"   args))
(define (s:p      . args) (s:common-tag "P"      args))
(define (s:strong . args) (s:common-tag "STRONG" args))
(define (s:table  . args) (s:common-tag "TABLE"  args))
(define (s:tbody  . args) (s:common-tag "TBODY"  args))
(define (s:thead  . args) (s:common-tag "THEAD"  args))
(define (s:th     . args) (s:common-tag "TH"     args))
(define (s:td     . args) (s:common-tag "TD"     args))
(define (s:title  . args) (s:common-tag "TITLE"  args))
(define (s:tr     . args) (s:common-tag "TR"     args))
(define (s:small  . args) (s:common-tag "SMALL"  args))
(define (s:quote  . args) (s:common-tag "QUOTE"  args))
(define (s:hr     . args) (s:common-tag "HR"     args))
(define (s:li     . args) (s:common-tag "LI"     args))
(define (s:ul     . args) (s:common-tag "UL"     args))
(define (s:ol     . args) (s:common-tag "OL"     args))
(define (s:dl     . args) (s:common-tag "DL"     args))
(define (s:dt     . args) (s:common-tag "DT"     args))
(define (s:dd     . args) (s:common-tag "DD"     args))
(define (s:pre    . args) (s:common-tag "PRE"    args))
(define (s:span   . args) (s:common-tag "SPAN"   args))
(define (s:label  . args) (s:common-tag "LABEL"  args))
(define (s:script . args) (s:common-tag "SCRIPT" args))

(define (s:dblquote  . args)
  (let* ((inputs (s:extract args))
         (data   (caar inputs))
         (params (s:process-params (cadr inputs))))
    (conc "&quot;" data "&quot;")))

(define (s:br     . args) "<BR>") ;;  THIS MAY NOT WORK!!!! BR CAN (MISTAKENLY) GET PARAM TEXT
;; (define (s:br     . args) (s:common-tag "BR"     args))
(define (s:font   . args) (s:common-tag "FONT"   args))
(define (s:err-font . args)
  (s:b (s:font 'color "red" args)))

(define (s:comment . args)
  (let* ((inputs (s:extract args))
         (data   (car inputs))
         (params (s:process-params (cadr inputs))))
    (list "<!--" data "-->")))

(define (s:null   . args) ;; nop
  (let* ((inputs (s:extract args))
         (data   (car inputs))
         (params (s:process-params (cadr inputs))))
    (list data)))

;; puts a nice box around a chunk of stuff
(define (s:fieldset legend . args)
  (list "<FIELDSET><LEGEND>" legend "</LEGEND>" args "</FIELDSET>"))

;; given a string return the string if it is non-white space or &nbsp; otherwise
(define (s:nbsp str)
  (if (string-match "^\\s*$" str)
      "&nbsp;"
      str))

;; USE 'page_override to override a linkto page from a button
(define (s:form   . args)
  ;; create a link for calling back into the current page and calling a specified 
  ;; function
  (let* ((action     (let ((v (s:find-param 'action args)))
                       (if v v "default")))
	 (id         (let ((i (s:find-param 'id args)))
		       (if i i #f)))
         (page       (let ((p (sdat-page s:session)))
                       (if p p "home")))
	 ;; (link       (session:link-to s:session page (if id
         ;;                                                 (list 'action action 'id id)
         ;;                                                 (list 'action action)))))
	 (link       (if (string=? (substring action 0 5) "http:") ;; if first part of string is http:
	        	 action
	        	 (session:link-to s:session 
	        			  page 
	        			  (if id
	        			      (list 'action action 'id id)
	        			      (list 'action action))))))
    ;; (script     (slot-ref s:session 'script))
    ;; (action-str (string-append script "/" page "?action=" action)))
    (s:common-tag "FORM" (append (s:remove-param-matching (s:remove-param-matching args 'action) 'id)
                                 (list 'action link)))))

;; look up the variable name (via the 'name tag) then inject the value from the session var
;; replacing the 'value value if it is already there, adding it if it is not.
(define (s:preserve tag args)
  (let* ((var-name (s:find-param 'name args)) ;; name='varname'
	 (value    (let ((v (s:get var-name)))
		     (if v v #f)))
	 (newargs  (append (s:remove-param-matching args 'value) (if value (list 'value value) '()))))
    (s:common-tag tag newargs)))

(define (s:input-preserve  . args)
  (s:preserve "INPUT" args))

;; text areas are done a little differently. The value is stored between the tags <textarea ...>the value goes here</textarea>
(define (s:textarea-preserve . args)
  (let* ((var-name (s:find-param 'name args))
	 (value    (let ((v (s:get var-name)))
		     (if v v #f))))
    (s:common-tag "TEXTAREA" (if value (cons value args) args))))

(define (s:option dat)
  (let ((len      (length dat)))
    (cond
     ((eq? len 1)
      (let ((item (car dat)))
	(s:option (list item item item))))
     ((eq? len 2)
      (s:option (append dat (list (car dat)))))
     (else
      (let ((label    (car dat))
	    (value    (cadr dat))
	    (dispval  (caddr dat))
	    (selected (if (> len 3)(cadddr dat) #f)))
	(list (conc "<OPTION " 
		    (if selected " selected " "")
		    "label=\"" label
		    "\" value=\"" value
		    "\">" dispval "</OPTION>")))))))

;; call only with (label (label value dispval [#t]) ...)
;; NB// sadly this block is redundantly almost identical to the s:select
;; fix that later ...
(define (s:optgroup dat)
  (let ((label (car dat))
	(rem   (cdr dat)))
    (if (null? rem)
	(s:common-tag "OPTGROUP" `('label ,label))
	(let loop ((hed (car rem))
		   (tal (cdr rem))
		   (res (list (conc "<OPTGROUP label=" label))))
	  ;; (print "hed: " hed " tal: " tal " res: " res)
	  (let ((new (append res (list (if (list? (cadr hed))
					   (s:optgroup hed)
					   (s:option hed))))))
	    (if (null? tal)
		(append new (list "</OPTGROUP>"))
		(loop (car tal)(cdr tal) new)))))))
    
;; items is a hierarchial alist
;; ( (label1 value1 dispval1 #t) ;; <== this one is selected
;;   (label2 (label3 value2 dispval2)
;;           (label4 value3 dispval3)))
;;     
;;  required arg is 'name
(define (s:select items . args)
  (if (null? items)
      (s:common-tag "SELECT" args)
      (let loop ((hed (car items))
		 (tal (cdr items))
		 (res '()))
	;; (print "hed: " hed " tal: " tal " res: " res)
	(let ((new (append res (list (if (and (> (length hed) 1)
					      (list? (cadr hed)))
					 (s:optgroup hed)
					 (s:option hed))))))
	  (if (null? tal)
	      (s:common-tag "SELECT" (cons new args))
	      (loop (car tal)(cdr tal) new))))))

(define (s:color  . args)
  "#00ff00")

(define (s:print indent inlst)
  (map (lambda (x)
         (cond 
          ((or (string? x)(symbol? x))
           (print (conc (make-string (* indent 2) #\ ) (s:any->string x))))
          ((list? x)
           (s:print (+ indent 1) x))
          (else
           ;; (print "ERROR: Bad input 01") ;; why do anything with junk?
           )))
       inlst))

;; Moved to misc-stml
;;
#;(define (s:cgi-out inlst)
  (s:output (current-output-port) inlst))

#;(define (s:output port inlst)
  (map (lambda (x)
	 (cond 
	  ((string? x) (print x)) ;; (print x))
	  ((symbol? x) (print x)) ;; (print x))
	  ((list? x)   (s:output port x))
	  (else ""
	   ;; (print "ERROR: Bad input 02") ;; why do anything? don't output junk.
	   )))
       inlst))
;  (if (> (length inlst) 2)
;      (print)))

#;(define (s:output-new port inlst)
  (with-output-to-port port
      (lambda ()
	(map (lambda (x)
	       (cond 
		((string? x) (print x))
		((symbol? x) (print x))
		((list? x)   (s:output port x))
		(else
		 ;; (print "ERROR: Bad input 03")
     )))
	     inlst))))

;;======================================================================
;; Not sure where these should go
;;======================================================================

;; (include "requirements.scm"), dbi has autoload, should not need this any more.

;;======================================================================
;; setup - convience calls to functions wrapped with a global s:session
;;======================================================================

;; macros in sugar don't work, have to load in all files or use compiled mode?
;;
;; (include "sugar.scm")

;; use this for getting data from page to page when scope and evals
;; get in the way
;; save data for use in the page generation here. Does NOT persist across page reads.

(define *page-data* (make-hash-table))

(define (s:lset! var val)
  (hash-table-set! *page-data* var val))
(define (s:lget var . default)
  (hash-table-ref/default *page-data* var (if (null? default)
					      #f
					      (car default))))

;; 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)))
	(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)
		 ((< num 100) 1000)
		 ((< num 200) 10000)
		 ((< num 300) 100000)
		 ((< num 400) 1000000) ;; can't imagine needing to get here. remember that this is for a single user
		 (else 100000000))
		(conc key-type (mkrandstr siz))
		(+ num 1))
	  (begin
	    (s:session-var-set! key val)
	    key)))))

;; given a key Xnnnn, look up the stored value and convert it appropriately, then
;; destroy the stored session var
;;
(define (s:key->val key)
  (let ((val (s:session-var-get key))
	(typ (string->symbol (substring key 0 1))))
    (if val
	(begin
	  (s:session-var-del! key)
	  ;; we take this opportunity to clean up old keyed session vars
	  ;; if more than 100 vars, remove all that are over 1-2 weeks old
					;(s:cleanup-session-vars)
	  (case typ
	    ((n)(string->number val))
	    ((s) val)
	    (else val)))
	val)))
  
;; clean up session vars
;;
(define (s:cleanup-session-vars)
  (let* ((session-vars (hash-table-keys (s:session-get-sessionvars)))
	 (week-num     (quotient (current-seconds) (* 7 24 60 60)))
	 (week         (number->string week-num  16)))
    (if (> (length session-vars) 100)
	(for-each
	 (lambda (var)
	   (if (> (string-length var) 5) ;; can't have keyed values with keys less than 5 characters long
	       (let ((var-week (string->number (substring var 1 4) 16)))
		 (if (and var-week
			  (>= (- week-num var-week) 2))
		     (s:session-var-del! var)))))
	 session-vars))))

;; inputs
;;
;; param: (dtype [tag1 tag2 ...])
;; dtype:
;;    'raw     : do no conversion
;;    'number  : convert to number, return #f if fails
;;    'escaped : use html-escape to protect the input
;;
(define (s:get-input key . params)
  (session:get-input s:session key params))

(define (s:get-input-keys)
  (session:get-input-keys s:session))

;; get-input else, get-param else #f
;;
(define (s:get-inp key . params)
  (or (apply s:get-input key params)
      (apply s:get-param key params)))

(define (s:load-model model)
  (session:load-model s:session model))

(define (s:model-path)
  (session:model-path s:session))

;; share data between pages calls. NOTE: This is not persistent
;; between cgi calls. Use sessionvars for that.
;;
(define (s:shared-hash)
  (sdat-shared-hash s:session))

(define (s:shared-set! key val)
  (hash-table-set! (sdat-shared-hash s:session) key val))

;; What to return when no value for key?
;;
(define (s:shared-get key)
  (hash-table-ref/default (sdat-shared-hash s:session) key #f))

;; http://foo.bar.com/pagename/p1/p2 => '("p1" "p2")
;;  #### DEPRECATED ####
(define (s:get-page-params)
  (sdat-path-params s:session))

(define (s:get-path-params)
  (sdat-path-params s:session))
	

(define (s:db)
  (sdat-conn s:session))

;;======================================================================
;; cgi and session stuff
;;======================================================================

;;(declare (uses cookie))
;;(declare (uses html-filter))
;;(declare (uses misc-stml))
;;(declare (uses formdat))
;;(declare (uses stml))
;;(declare (uses session))
;;(declare (uses setup)) ;; s:session gets created here
;;(declare (uses sqltbl))
;;(declare (uses keystore))

;; given a list of symbols give the count of the matching symbol
;; l => '(a b c)  (dumobj:indx a 'b) => 1
(define (s:get-fieldnum lst field-name)
  (let loop ((head (car lst))
             (tail (cdr lst))
             (fnum 0))
    (if (eq? head field-name) fnum
        (if (null? tail) #f
            (loop (car tail)(cdr tail)(+ fnum 1))))))

(define (s:fields->string lst)
  (string-join (map symbol->string lst) ","))

(define (s:vector-get-field vec field field-list)
  (vector-ref vec (s:get-fieldnum field-list field)))

;;======================================================================
;;
;;======================================================================

;; moved to misc-stml
;;
#;(define (err:log . msg)
  (with-output-to-port (current-error-port) ;; (slot-ref self 'logpt)
    (lambda () 
      (apply print msg))))

(define (s:tidy-url url)
  (if url
      (let ((r1 (regexp "^http:\\/\\/"))
            (r2 (regexp "^[ \\t]*$"))) ;; blank
        (if (string-match r1 url) url
            (if (string-match r2 url) #f ;; convert a blank to #f
                (conc "http://" url))))
      url))

(define (s:lazy->num num)
  (if (number? num) num
      (if (string->number num) (string->number num)
	    (if num 1 0)))) ;; wierd eh! yep, #f=>0 #t=>1 

;;======================================================================
;; D B
;;======================================================================

;; convert values to appropriate strings
;;
#;(define (s:sqlparam-val->string val)
  (cond
   ((list?   val)(string-join (map symbol->string val) ",")) ;; (a b c) => a,b,c
   ((string? val)(conc "'" (dbi:escape-string val) "'"))
   ((number? val)(number->string val))
   ((symbol? val)(dbi:escape-string (symbol->string val)))
   ((boolean? val)
    (if val "TRUE" "FALSE"))  ;; should this be "TRUE" or 1?
                              ;; should this be "FALSE" or 0 or NULL?
   (else
    (err:log "sqlparam: unknown type for value: " val)
    "")))

;; (sqlparam "INSERT INTO foo(name,age) VALUES(?,?);" "bob" 20)
;; NB// 1. values only!! 
;;      2. terminating semicolon required (used as part of logic)
;;
;; a=? 1 (number) => a=1
;; a=? 1 (string) => a='1'
;; a=? #f         => a=FALSE 
;; a=? a (symbol) => a=a 
;;
#;(define (s:sqlparam query . args)
  (let* ((query-parts (string-split query "?"))
         (num-parts    (length query-parts))
         (num-args    (length args)))
    (if (not (= (+ num-args 1) num-parts))
        (err:log "ERROR, sqlparam: wrong number of arguments or missing semicolon, " num-args " for query " query)
        (if (= num-args 0) query
            (let loop ((section (car query-parts))
                       (tail    (cdr query-parts))
                       (result  "")
                       (arg     (car args))
                       (argtail (cdr args)))
              (let* ((valstr    (s:sqlparam-val->string arg))
                     (newresult (conc result section valstr)))
                (if (null? argtail) ;; we are done
                    (conc newresult (car tail))
                    (loop
                     (car tail)
                     (cdr tail)
                     newresult
                     (car argtail)
                     (cdr argtail)))))))))

;;======================================================================
;; M I S C   S T R I N G   S T U F F
;;======================================================================

(define (s:string-downcase str)
  (if (string? str)
      (string-translate str "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyz")
      str)) 

;; (define session:valid-chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789")
#;(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)))

#;(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)))
	(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.
;;
(define (s:crypt-passwd pw s)
  (c:crypt pw (or s (c:crypt-gensalt))))

(define (s:password-match? password crypted)
  (let* ((salt (substring crypted 0 2))
         (pcrypted (s:crypt-passwd password salt)))
    ;; (s:log "INFO: pcrypted=" pcrypted " crypted=" crypted)
    (and (string? password)
         (string? pcrypted)
         (string=? pcrypted crypted))))

;; (read-line (open-input-pipe "echo foo | mkpasswd -S ab -s"))

;; BUG: The regex implements a rule, but what rule? AH! usaztempe, get rid of this? No, this also looks for &key=value ...
(define (s:validate-uri)
  (let ((uri (get-environment-variable "REQUEST_URI"))
	(qrs (get-environment-variable "QUERY_STRING")))
    (if (not uri)
	(set! uri qrs))
    (if uri
	(string-match 
	 (regexp "^(/[a-z\\-\\._:0-9]*)*(|\\?([A-Za-z0-9_\\-\\+]+=[A-Za-z0-9_\\-\\.\\+]*&{0,1})*)$") uri)
	(begin
	  "REQUEST URI NOT AVAILABLE!"
	  (let ((p (open-input-pipe "env")))
	    (let loop ((l (read-line p))
		       (res '()))
	      (if (eof-object? l)
		  res
		  (loop (read-line p)(cons (list l "<BR>") res)))))
	  #t))))

;; moved to misc-stml
;;
;; anything except a list is converted to a string!!!
#;(define (s:any->string val)
  (cond
   ((string? val) val)
   ((number? val) (number->string val))
   ((symbol? val) (symbol->string val))
   ((eq? val #f) "")
   ((eq? val #t) "TRUE")
   ((list? val) val)
   (else 
    (let ((ostr (open-output-string)))
      (with-output-to-port ostr
	(lambda ()
	  (display val)))
      (get-output-string ostr)))))

#;(define (s:any->number val)
  (cond
   ((number? val)  val)
   ((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)
   (else #f)))

(define (s:any->pgint val)
  (let ((n (s:any->number val)))
    (if n
	(if (s:illegal-pgint n)
	    #f
	    n)
	n)))

;; string is a string and non-zero length
(define (misc:non-zero-string str)
  (if (and (string? str)
           (> (string-length str) 0))
      str
      #f))

;;======================================================================
;; html-filter
;;======================================================================
(define (s:split-string strng delim)
  (if (eq? (string-length strng) 0) (list strng)
      (let loop ((head (make-string 1 (car (string->list strng))))
		 (tail (cdr (string->list strng)))
		 (dest '())
		 (temp ""))
	(cond ((equal? head delim)
	       (set! dest (append dest (list temp)))
	       (set! temp ""))
	      ((null? head) 
	       (set! dest (append dest (list temp))))
	      (else (set! temp (string-append temp head)))) ;; end if
	(cond ((null? tail)
	       (set! dest (append dest (list temp))) dest)
	      (else (loop (make-string 1 (car tail)) (cdr tail) dest temp))))))

;; allowed-tags is a list of tags as symbols:
;;   '(a b center p a)
;; parsing is simplistic and the response conservative
;; if a < is found without the tag and closing > then
;; the < or > is replaced with &lt; or &gt; without 
;; even trying hard to figure out if there is a legit tag 
;; buried in the text somewhere.
;; a list of strings is returned.
;;
;; NOTES
;; 1. case is important in the allowed-tags list!
;; 2. only "solid" tags are supported i.e. <a href="foo"> will not work?
;;

;; (s:cgi-out (eval (s:output (s:html-filter "hello<b>goodbye</b><b> eh" '(a b i))))

;; strategy
;; 1. convert \n to <linefeed>
;; 2. Split on "<"
;; 3. Split on ">"
;; 4. Fix
(define (s:html-filter input-text allowed-tags)
  (let* ((toks   (s:str->toks input-text))
	 (tmp    (s:toks->stml '(s:null) #f toks allowed-tags))
	 (res    (car tmp))
	 (nxttag (cadr tmp))
	 (rem    (caddr tmp)))
    res))

(define (s:html-filter->string input-text allowed-tags)
  (let ((ostr (open-output-string)))
    ;;; (s:output-new ostr (s:html-filter input-text allowed-tags))
    (s:output-new ostr (car (eval (s:html-filter input-text allowed-tags))))
    (string-chomp (get-output-string ostr)))) ;; don't need the linefeed, could stop adding it ...
	
;;     (if (null? rem)
;; 	res '())
;; 	(s:toks->stml (if (list? res) res '()) #f rem allowed-tags))))

(define (s:str->toks str)
  (apply append (map (lambda (tok)
		       (intersperse (s:split-string tok ">") ">")) 
		     (intersperse (s:split-string str "<") "<"))))

(define (s:tag->stml tag)
  (string->symbol (string-append "s:" (symbol->string tag))))


(define (s:toks->stml res tag rem allowed)
  ;; (print "tag: " tag " rem: " rem)
  (if (null? rem)
      (list (append res (if tag
			    (list (s:tag->stml tag))
				'())) #f '() allowed) ;; the case of a lone tag 
      ;; handle a starting tag
      (let* ((tmp       (s:upto-tag rem allowed))
	     (txt       (car tmp))      ;; this txt goes with tag!!!
	     (nexttag   (cadr tmp))     ;; this is the NEXT DAMN tag!
	     (begin-tag (caddr tmp))
	     (newrem    (cadddr tmp)))
	;; (print "txt:        " txt "\nnexttag:    " nexttag "\nbegin-tag:  " begin-tag "\nnewrem:     " newrem "\nres:        " res "\n")
	(if begin-tag ;; nest the following stuff
	    (let* ((childdat (s:toks->stml '() nexttag newrem allowed))
		   (child    (car childdat))
		   (newtag   (cadr childdat))
		   (newrem2  (caddr childdat))
		   (allowed  (cadddr childdat))) ;; ya, it shouldn't have changed
	      (if tag 
		  (s:toks->stml (append res (list (append (list (s:tag->stml tag)) child (list txt))))
				newtag newrem2 allowed)
		  (s:toks->stml (append res (list txt) child)
				newtag newrem2 allowed)))
	    ;; it must have been an end tag
	    (list (append res (list 
			       (if tag
				   (list (s:tag->stml tag) txt)
				   txt)))
		  #f
		  newrem
		  allowed)))))


;; "<" "b" ">"  => "<b>"
;; "<"
;; (define (s:rebuild-tags input-list)

;; ("blah blah" "<" "b" ">" "more stuff" "<" "i" ">" ) 
;;     => ("blah blah" b #t ( "more stuff" "<" "i" ">" ))
;; ("blah blah" "<" "/b" ">" "more stuff" "<" "i" ">" ) 
;;     => ("blah blah" b #f ( "more stuff" "<" "i" ">" ))
(define (s:upto-tag inlst allowed-tags)
  (if (null? inlst) inlst
      (let loop ((tok  (car inlst))
		 (tail (cdr inlst))
		 (prel "")) ;; create a string or a list of string parts?
	(if (string=? tok "<") ;; might have a tag
	    (if (> (length tail) 1) ;; to be a tag, need tag and closing ">"
		(let ((tag (car tail))
		      (end (cadr tail))
		      (rem (cddr tail))) 
		  (if (string=? end ">") ;; yep, it is probably a tag
		      (let* ((trim-tag (if  (string=? "/" (substring tag 0 1))
					    (substring tag 1 (string-length tag)) #f))
			     (tag-sym  (string->symbol (if trim-tag trim-tag tag))))
			(if (member tag-sym allowed-tags)
			    ;; have a valid tag, rebuild it and return the result
			    (list prel tag-sym (if trim-tag #f #t) rem)
			    ;; not a valid tag, convert "<" and ">" and add all to prel
			    (let ((newprel (string-append prel "&lt;" tag "&gt;")))
			      (if (null? rem)(list newprel #f #f '()) ;; return newprel - add #f #f ???
				  (loop (car rem)(cdr rem) newprel)))))
		      ;; so, it wasn't a tag
		      (let ((newprel (string-append prel "&lt;" tag)))
			(if (null? tail)
			    (list newprel #f #f '())
			    (loop (car rem)(cdr rem) newprel)))))
		;; too short to be a tag
		(list (apply string-append prel "&lt;" tail) #f #f '()))
	    (if (null? tail) 
		;; we're done
		(list (string-append prel tok) #f #f '())
		(loop (car tail)(cdr tail)(string-append prel tok)))))))


(define (s:divy-up-cgi-str instr)
  (map (lambda (x) (string-split x "=")) (string-split instr "&")))

(define (s:decode-str instr)
  (let* ((abc (string-substitute "\\+" " " instr #t))
	 (toks (s:split-string abc "%")))
    (if (< (length toks) 2) abc
	(let loop ((head (cadr toks))
		   (tail (cddr toks))
		   (result (car toks)))
	  (if (string=? head "")
	      (if (null? tail)
		  result
		  (loop (car tail)(cdr tail) result))
	      (let* ((key (substring head 0 2))
		     (rem (substring head 2 (string-length head)))
		     (num (string->number key 16))
		     (ch  (if (and (number? num)
                                   (exact? num))
			      (integer->char num)
			      #f)) ;; this is an error. I will probably regret this some day
		     (chstr  (if ch (make-string 1 ch) ""))
		     (newres (if ch
				 (string-append result chstr rem)
				 (string-append result head))))
		;; (print "head: " head " num: " num " ch: |" ch "| chstr: " chstr)
		(if (null? tail)
		    newres
		    (loop (car tail)(cdr tail) newres))))))))

;; probably a bug:
;;
;; (s:process-cgi-input "=bar")
;; => ((bar ""))
;;
(define (s:process-cgi-input instr)
  (map (lambda (xy)
         (list (string->symbol (s:decode-str (car xy)))
               (if (eq? (length xy) 1) 
                   ""
                   (s:decode-str (cadr xy)))))
         (s:divy-up-cgi-str instr)))

;; for testing -- deletme
;; (define blah "post_title=%2B%2B%2B%2B%2B%2B%2B%2B%2B%2B%2Bhello-------------+++++++++++%26%26%26%26%26%26%26%26%26%40%40%40%40%40%40%40%40%40&post_body=%2B%2B%2B%2B%2B%2B%2B%2B%2B%2B%2Bhello-------------+++++++++++%26%26%26%26%26%26%26%26%26%40%40%40%40%40%40%40%40%40%0D%0A%0D%0A%2B%2B%2B%2B%2B%2B%2B%2B%2B%2B%2Bhello-------------+++++++++++%26%26%26%26%26%26%26%26%26%40%40%40%40%40%40%40%40%40%0D%0A%0D%0A%0D%0A%2B%2B%2B%2B%2B%2B%2B%2B%2B%2B%2Bhello-------------+++++++++++%26%26%26%26%26%26%26%26%26%40%40%40%40%40%40%40%40%40&new_post=Submit")
;; (define blah2 "post_title=5%25&post_body=and+10%25&new_post=Submit")

;;======================================================================
;; formdat
;;======================================================================

(define formdat:*debug* #f)

;; Old data format was something like this. BUT! 
;; Forms do not have names so the hierarcy is
;; unnecessary (I think)
;;
;; hashtable
;;   |-formname --> <formdat> 'form-name=formname
;;   |                        'form-data=hashtable
;;   |                                       | name => value
;;
;; New data format is only the <formdat> portion from above

;; (define-class <formdat> ()
;;    (form-data
;;    ))
(define (make-formdat:formdat)(vector (make-hash-table)))
(define (formdat:formdat-get-data   vec)    (vector-ref  vec 0))
(define (formdat:formdat-set-data!  vec val)(vector-set! vec 0 val))

(define (formdat:initialize self)
  (formdat:formdat-set-data! self (make-hash-table)))

(define (formdat:get self key)
  (hash-table-ref/default 
   (formdat:formdat-get-data self)
   (cond 
    ((symbol? key) key)
    ((string? key) (string->symbol key))
    (else key))
   #f))

;; change to convert data to list and append val if already exists
;; or is a list
(define (formdat:set! self key val)
  (let ((prev-val (formdat:get self key))
        (ht       (formdat:formdat-get-data self)))
    (if prev-val
        (if (list? prev-val)
            (hash-table-set! ht key (cons val prev-val))
            (hash-table-set! ht key (list val prev-val)))
        (hash-table-set! ht key val))
    self))

(define (formdat:keys self)
  (hash-table-keys (formdat:formdat-get-data self)))

(define (formdat:printall self printproc)
  (printproc "formdat:printall " (formdat:keys self))
  (for-each (lambda (k)
	      (printproc k " => " (formdat:get self k)))
	    (formdat:keys self)))

(define (formdat:all->strings self)
  (let ((res '()))
    (for-each (lambda (k)
                 (set! res (cons (conc k "=>" (formdat:get self k)) res)))
              (formdat:keys self))
        res))

;; call with *one* of the lists in the list of lists created by CGI:url-unquote
(define (formdat:load self formlist)
  (let ((ht             (formdat:formdat-get-data self)))
    (if (null? formlist) self ;; no values provided, return self for no good reason
        (let loop ((head (car formlist))
                   (tail (cdr formlist)))
          (let ((key (car head))
                (val (cdr head)))
            ;; (err:log "key=" key " val=" val)
	    (if (> (length val) 1)
		(formdat:set! self key val)
		(formdat:set! self key (car val)))
            (if (null? tail) self   ;; we are done
                (loop (car tail)(cdr tail))))))))

;; get the header from datstr
(define (formdat:read-header datstr) ;; datstr is an input string port
  (let loop ((hs (read-line datstr))
	     (header '()))
    (if (or (eof-object? hs)
	    (string=? hs ""))
	header
	(loop (read-line datstr)(append header (list hs))))))

;; get the data up to the next key. if there is no key then return #f
;; return (dat remdat)
(define (formdat:read-dat dat key)
  (let ((index (substring-index key dat))) ;; (string-search-positions key dat)))
    (if (or (not index)
	    (null? index)) ;; the key was not found
	#f
	(let* ((datstr (open-input-string dat))
	       ;; (result (read-string (caar index) datstr))
	       (result (read-string index datstr))
	       (remdat (read-string #f datstr)))
	  (close-input-port datstr)
	  (list result remdat)))))

 ;; inp is port to read data from, maxsize is max data allowed to read (total)
(define (formdat:dat->list inp maxsize #!key (debug-port #f))
  ;; read 1Meg chunks from the input port. If a block is not complete
  ;; tack on the next 1Meg chunk as needed. Set up so the header is always
  ;; at the beginning of the chunk
  ;;-----------------------------29932024411502323332136214973
  ;;Content-Disposition: form-data; name="input-picture"; filename="breadfruit.jpg"
  ;;Content-Type: image/jpeg
  (let loop ((dat (read-string 1000000 inp))
	     (res '())
	     (siz 0))
    (if debug-port (format debug-port "dat: ~A\n" dat))
    (if debug-port (format debug-port "eof: ~A\n" (eof-object? (read inp))))
    
    (if (> siz maxsize)
	(begin
	  (print "DATA TOO BIG")
	  res)
	(let* ((datstr (open-input-string dat))
	       (header (formdat:read-header datstr))
	       (key    (if (not (null? header))(car header) #f))
	       (remdat (read-string #f datstr))          ;; used in next line, discard if got data, else revert to
	       (alldat (if key (formdat:read-dat remdat key) #f))    ;; try to extract the data
	       (thsdat (if alldat (car alldat)  #f))     ;; the data
	       (newdat (if alldat (cadr alldat) #f))     ;; left over data, must process ...
	       (thsres (list header thsdat))             ;; speculatively construct results
	       (newres (append res (list thsres))))      ;; speculatively construct results
	  (close-input-port datstr)
	  (cond
	   ;; either no header or single input
	   ((and (not alldat)
		 (or (null? header)
		     (not (string-match formdat:delim-patt-rex (car header)))))
	    ;; (print "Got here")
	    (cons (list header "") res)) ;; note use header as dat and use "" as header????
	   ;; didn't find end key in this block
	   ((not alldat)
	    (let ((mordat (read-string 1000000 inp)))
	      (if (string=? mordat "") ;; there is no more data, discard results and use remdat as data, this input is broken
		  (cons (list header remdat) res)
		  (loop (string-append dat mordat) res (+ siz 2000000))))) ;; add the extra 1000000
	   (alldat ;; got data, don't attempt to check if there is more, just loop and rely on (not alldat) to get more data
	    (loop newdat newres (+ siz 1000000))))))))

(define formdat:bin-data-disp-rex (regexp "^Content-Disposition:\\s+form-data;"))
(define formdat:bin-data-name-rex (regexp "\\Wname=\"([^\"]+)\""))
(define formdat:bin-file-name-rex (regexp "\\Wfilename=\"([^\"]+)\""))
(define formdat:bin-file-type-rex (regexp "Content-Type:\\s+([^\\s]+)"))
(define formdat:delim-patt-rex    (regexp "^\\-+[0-9]+\\-*$"))

;; returns a hash with entries for all forms - could well use a proplist?
(define (formdat:load-all)
  (let ((request-method (get-environment-variable "REQUEST_METHOD")))
    (if (and request-method
	     (string=? request-method "POST"))
	(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"))))
    ;; (write-string (read-string #f inp) #f debugp)  ;; destroys all data!
    (formdat:initialize formdat)
    (let ((alldats (formdat:dat->list inp 10e6 debug-port: debugp)))
      
      (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)))
	(if multipass
	    ;; handle multi-part form
	    (for-each (lambda (datlst)
			(let* ((header (formdat:extract-header-info (car datlst)))
			       (name   (if (assoc 'name header)
					   (string->symbol (cadr (assoc 'name header)))
					   "")) ;; grumble
			       (fnamel  (assoc 'filename header))
			       (content (assoc 'content header))
			       (dat    (cadr datlst)))
			  ;; (print "header: " header " name: " name " fnamel: " fnamel " content: " content) ;;  " dat: " (dat)
			  (formdat:set! formdat 
					name
					(if fnamel 
					    (list (cadr fnamel)
						  (if content
						      (cadr content)
						      "unknown")
						  (string->blob dat))
					    dat))))
		      alldats)
	    ;; handle single part form
	    ;; 	(if (and (string? name)
	    ;; 		     (string=? name "")) ;; this is the short form input I guess
	    ;; 		(let* ((datstr (caar datlst))
	    ;; 		       (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))
	;; (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))

;; or

(define inp (open-input-file "tests/example.post.binary.in"))
(define dat (read-string #f inp))
(define datstr (open-input-string dat))

(formdat:read-header datstr)

(define dat (formdat:dat->list inp 10e6))
(close-input-port inp)
|#
  
(define (formdat:extract-header-info header)
  (if (null? header)
      '()
      (let loop ((hed (car header))
		 (tal (cdr header))
		 (res '()))
	(if (string-match formdat:bin-data-disp-rex hed) ;; 
	    (let* ((data-namem (string-match formdat:bin-data-name-rex hed))
		   (file-namem (string-match formdat:bin-file-name-rex hed))
		   (data-name  (if data-namem (cadr data-namem) #f))
		   (this       (if file-namem
				   (list (list 'name data-name)(list 'filename (cadr file-namem)))
				   (list (list 'name data-name)))))
	      (if (null? tal)
		  (append res this)
		  (loop (car tal)(cdr tal)(append res this))))
	    (let ((content (string-match formdat:bin-file-type-rex hed))) ;; this is the stanza for the content type
	      (if content
		  (let ((newres (cons (list 'content (cadr content)) res)))
		    (if (null? tal)
			newres
			(loop (car tal)(cdr tal) newres)))
		  (if (null? tal)
		      res
		      (loop (car tal)(cdr tal) res)
		      )))))))

;;	      (let loop ((l       (read-line)) ;; (if (eq? mode 'norm)(read-line)(read-char)))
;;			 (endline #f)
;;			 (num     0))
;;		;; (format debugp "~A\n" l)
;;              (if (or (not (eof-object? l))
;;		      (not (and (eq? mode 'bin)
;;				(string=? l "")))) ;; if in bin mode empty string is end of file
;;		  (case mode
;;		    ((start)
;;		     (set! mode 'norm)
;;		     (if (string-match delim-patt-rex l)
;;			 (begin
;;			   (set! delim-string l)
;;			   (set! delim-len    (string-length l))
;;			   (loop (read-line) #f 0))
;;			 (loop l #f 0)))
;;		    ((norm)
;;		     ;; I don't like how this gets checked on every single input. Must be a better way. FIXME
;;		     (if (and (string-match bin-data-disp-rex l)
;;			      (string-match bin-data-name-rex l)
;;			      (string-match bin-file-name-rex l))
;;			 (begin
;;			   (set! data-name (cadr (string-match bin-data-name-rex l)))
;;			   (set! file-name (cadr (string-match bin-file-name-rex l)))
;;			   (set! mode 'content)
;;			   (loop (read-line) #f num)))
;;		     (let* ((dat  (s:process-cgi-input l))) ;; (CGI:url-unquote l))
;;		       (format debugp "PROCESS-CGI-INPUT: ~A\n" (intersperse dat ","))
;;		       (formdat:load formdat dat)
;;		       (loop (read-line) #f num)))
;;		    ((content)
;;		     (if (string-match bin-file-type-rex l)
;;			 (begin 
;;			   (set! mode 'bin)
;;			   (set! data-type (cadr (string-match bin-file-type-rex l)))
;;			   (loop (read-string 1) #f num))))
;;		    ((bin)
;;		     ;; delim-string: \n"---------------12345"
;;		     ;;                  012345678901234567890
;;		     ;; endline:        "---------------12"
;;		     ;; l = "3"
;;		     ;; delim-len = 20
;;		     ;; (substring  "---------------12345" 17 18) => "3"
;;		     ;;
;;		     (cond
;;		       ;; haven't found the start of an endline, is the next char a newline?
;;		      ((and (not endline)
;;			    (string=? l "\n")) ;; required first character 
;;		       (let ((newendline (open-output-string)))
;;			 ;; (write-line l newendline) ;; discard the newline. add it back if don't have a lock on delim-string
;;			 (loop (read-string 1) newendline (+ num 1))))
;;		      ((not endline)
;;		       (write-string l #f bin-dat)
;;		       (loop (read-string 1) #f (+ num 1)))
;;		      ;; string so far matches delim-string
;;		      (endline
;;		       (let* ((endstr (get-output-string endline))
;;			      (endlen (string-length endstr)))
;;			 (if (> endlen 0)
;;			     (format debugp " delim: ~A\nendstr: ~A\n" delim-string endstr))
;;			 (if (and (> delim-len endlen)
;;				  (string=? l (substring delim-string endlen (+ endlen 1))))
;;			     ;; yes, this character matches the next in the delim-string
;;			     (if (eq? delim-len endlen) ;; have a match! Ignore that a newline is required. Lazy bugger.
;;				 (let* ((fn      (string->symbol data-name)))
;;				   (formdat:set! formdat fn (list file-name data-type (string->blob (get-output-string bin-dat))))
;;				   (set! mode 'norm)
;;				   (loop (read-line) #f 0))
;;				 (begin
;;				   (write-string l #f endline)
;;				   (loop (read-string 1) endline (+ num 1))))
;;			     ;; no, this character does NOT match the next in line in delim-string
;;			     (begin
;;			       (write-string "\n" #f bin-dat) ;; don't forget that newline we dropped
;;			       (write-string endstr #f bin-dat)
;;			       (write-string l #f bin-dat)
;;			       (loop (read-string 1) #f (+ num 1))))))))
;;		    )))))

;;    (formdat:printall formdat (lambda (x)(write-line x debugp)))

#|
(define inp (open-input-file "/tmp/stmlrun/delme-33.log.keep-for-ref"))
(define dat (read-string #f inp))
(close-input-port inp)
|#

;;======================================================================
;; use a table in your db called metadat to store key value pairs
;;======================================================================


(define (keystore:get db key)
  (dbi:get-one db "SELECT value FROM metadata WHERE key=?;" key))

(define (keystore:set! db key value)
  (let ((curr-val (keystore:get db key)))
    (if curr-val
	(dbi:exec db "UPDATE metadata SET value=? WHERE key=?;" value key)
	(dbi:exec db "INSERT INTO metadata (key,value) VALUES (?,?);" key value))))

(define (keystore:del! db key)
  (dbi:exec db "DELETE FROM metadata WHERE key=?;" key))

;;======================================================================
;; stuff from misc-stml.scm
;;======================================================================

;; moved to stmlcommon
;; (bunch of stuff)

;; moved from stmlcommon
;;
;; anything except a list is converted to a string!!!
(define (s:any->string val)
  (cond
   ((string? val) val)
   ((number? val) (number->string val))
   ((symbol? val) (symbol->string val))
   ((eq? val #f) "")
   ((eq? val #t) "TRUE")
   ((list? val) val)
   (else 
    (let ((ostr (open-output-string)))
      (with-output-to-port ostr
	(lambda ()
	  (display val)))
      (get-output-string ostr)))))

(define (s:any->number val)
  (cond
   ((number? val)  val)
   ((string? val)  (string->number val))
   ((symbol? val)  (string->number (symbol->string val)))
   (else     #f)))

;; Moved from stmlcommon
;;
(define (s:cgi-out inlst)
  (s:output-new (current-output-port) inlst))

#;(define (s:output port inlst)
  (map (lambda (x)
	 (cond 
	  ((string? x) (print x)) ;; (print x))
	  ((symbol? x) (print x)) ;; (print x))
	  ((list? x)   (s:output port x))
	  (else ""
	   ;; (print "ERROR: Bad input 02") ;; why do anything? don't output junk.
	   )))
       inlst))
;  (if (> (length inlst) 2)
;      (print)))

(define (s:output-new port inlst)
  (with-output-to-port port
      (lambda ()
	(map (lambda (x)
	       (cond 
		((string? x) (print x))
		((symbol? x) (print x))
		((list? x)   (s:output-new port x))
		(else
		 ;; (print "ERROR: Bad input 03")
     )))
	     inlst))))
           
(define (err:log . msg)
  (with-output-to-port (current-error-port) ;; (slot-ref self 'logpt)
    (lambda () 
      (apply print msg))))

;;======================================================================
;; D B
;;======================================================================

;; convert values to appropriate strings
;;
(define (s:sqlparam-val->string val)
  (cond
   ((list?   val)(string-join (map symbol->string val) ",")) ;; (a b c) => a,b,c
   ((string? val)(conc "'" (dbi:escape-string val) "'"))
   ((number? val)(number->string val))
   ((symbol? val)(dbi:escape-string (symbol->string val)))
   ((boolean? val)
    (if val "TRUE" "FALSE"))  ;; should this be "TRUE" or 1?
                              ;; should this be "FALSE" or 0 or NULL?
   (else
    (err:log "sqlparam: unknown type for value: " val)
    "")))

;; (sqlparam "INSERT INTO foo(name,age) VALUES(?,?);" "bob" 20)
;; NB// 1. values only!! 
;;      2. terminating semicolon required (used as part of logic)
;;
;; a=? 1 (number) => a=1
;; a=? 1 (string) => a='1'
;; a=? #f         => a=FALSE 
;; a=? a (symbol) => a=a 
;;
(define (s:sqlparam query . args)
  (let* ((query-parts (string-split query "?"))
         (num-parts    (length query-parts))
         (num-args    (length args)))
    (if (not (= (+ num-args 1) num-parts))
        (err:log "ERROR, sqlparam: wrong number of arguments or missing semicolon, " num-args " for query " query)
        (if (= num-args 0) query
            (let loop ((section (car query-parts))
                       (tail    (cdr query-parts))
                       (result  "")
                       (arg     (car args))
                       (argtail (cdr args)))
              (let* ((valstr    (s:sqlparam-val->string arg))
                     (newresult (conc result section valstr)))
                (if (null? argtail) ;; we are done
                    (conc newresult (car tail))
                    (loop
                     (car tail)
                     (cdr tail)
                     newresult
                     (car argtail)
                     (cdr argtail)))))))))

;; (define session:valid-chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789")
(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)))

(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)))
	(if (> n len) res
	    (loop (string-append res (substring seed-string char-num (+ char-num 1)))
		  (+ n 1)))))))


;;======================================================================
;; P A R A M S
;;======================================================================

;; input: 'a ('a "val a" 'b "val b") => "val a"
(define (s:find-param key param-lst)
  (let loop ((head (car param-lst))
	     (tail (cdr param-lst)))
    (if (eq? head key)
	(car tail)
	(if (< (length tail) 2) #f
	    (loop (cadr tail)(cddr tail))))))

(define (s:param->string param)
  (conc (symbol->string (car param)) "=" "\"" (cadr param) "\""))

;; remove 'foo "bar" from ('foo "bar" 'bar "foo")
(define (s:remove-param-matching params key)
  (if (= (length params) 0)'() ;;  proper params list >= 2 items
      (let loop ((head     (car params))
                 (tail     (cdr params))
                 (result   '()))
        (if (symbol? head) ;; symbols have params
            (let ((val     (car tail))
                  (newtail (cdr tail)))
              (if (eq? head key)  ;; get rid of this one
                  (if (null? newtail) result
                      (loop (car newtail)(cdr newtail) result))
                  (let ((newresult (append result (list head val))))
                    (if (null? newtail) newresult
                        (loop (car newtail)(cdr newtail) newresult)))))
            (let ((newresult (append result (list head))))
              (if (null? tail) newresult
                  (loop (car tail)(cdr tail) newresult)))))))

(define (session:get-param-from params key)
  (let ((r1 (regexp (conc "^" (s:any->string key) "=(.*)$"))))
    (if (null? params) #f
        (let loop ((head (car params))
                   (tail (cdr params)))
          (let ((match (string-match r1 head)))
            (if match
                (list-ref match 1)
                (if (null? tail) #f
                    (loop (car tail)(cdr tail)))))))))

(define (s:process-params params)
  (if (null? params) ""
      (let loop ((res "")
                 (head (car params))
                 (tail (cdr params)))
        (if (null? tail)
            (conc res " " (s:param->string head))
            (loop
             (conc res " " (s:param->string head))
             (car tail)
             (cdr tail))))))

;; remove key=var from (key=var key1=var1 key2=var2 ...)
(define (k=v-params:remove-matching params key)
  (if (= (length params) 0) params
      (let ((r1 (regexp (conc "^" key "="))))
        (let loop ((head (car params))
                   (tail (cdr params))
                   (result '()))
          (if (string-match r1 head)
              (if (null? tail) result
                  (loop (car tail)(cdr tail) result))
              (let ((newlst (cons head result)))
                (if (null? tail) newlst
                    (loop (car tail)(cdr tail) newlst))))))))

;;======================================================================
;; stuff pulled from session
;;======================================================================


;; sessions table
;; id session_id session_key
;; create table sessions (id serial not null,session-key text);

;; session_vars table
;; id session_id page_id key value
;; create table session_vars (id serial not null,session_id integer,page text,key text,value text);

;; TODO
;;  Concept of order num incremented with each page access
;;     if a branch is taken then a new session would need to be created
;;

;; make-vector-record session session dbtype dbinit conn params path-params session-key session-id domain toppage page curr-page content-type page-type sroot twikidir pagedat alt-page-dat pagevars pagevars-before sessionvars sessionvars-before globalvars globalvars-before logpt formdat request-method session-cookie curr-err log-port logfile seen-pages page-dir-style debugmode
;; (define (make-sdat)(make-vector 36))
;; (define (sdat-dbtype               vec)    (vector-ref  vec 0))
;; (define (sdat-dbinit               vec)    (vector-ref  vec 1))
;; (define (sdat-conn                 vec)    (vector-ref  vec 2))
;; (define (sdat-pgconn               vec)    (vector-ref (vector-ref vec 2) 1))
;; (define (sdat-params               vec)    (vector-ref  vec 3))
;; (define (sdat-path-params          vec)    (vector-ref  vec 4))
;; (define (sdat-session-key          vec)    (vector-ref  vec 5))
;; (define (sdat-session-id           vec)    (vector-ref  vec 6))
;; (define (sdat-domain               vec)    (vector-ref  vec 7))
;; (define (sdat-toppage              vec)    (vector-ref  vec 8))
;; (define (sdat-page                 vec)    (vector-ref  vec 9))
;; (define (sdat-curr-page            vec)    (vector-ref  vec 10))
;; (define (sdat-content-type         vec)    (vector-ref  vec 11))
;; (define (sdat-page-type            vec)    (vector-ref  vec 12))
;; (define (sdat-sroot                vec)    (vector-ref  vec 13))
;; (define (sdat-twikidir             vec)    (vector-ref  vec 14))
;; (define (sdat-pagedat              vec)    (vector-ref  vec 15))
;; (define (sdat-alt-page-dat         vec)    (vector-ref  vec 16))
;; (define (sdat-pagevars             vec)    (vector-ref  vec 17))
;; (define (sdat-pagevars-before      vec)    (vector-ref  vec 18))
;; (define (sdat-sessionvars          vec)    (vector-ref  vec 19))
;; (define (sdat-sessionvars-before   vec)    (vector-ref  vec 20))
;; (define (sdat-globalvars           vec)    (vector-ref  vec 21))
;; (define (sdat-globalvars-before    vec)    (vector-ref  vec 22))
;; (define (sdat-logpt                vec)    (vector-ref  vec 23))
;; (define (sdat-formdat              vec)    (vector-ref  vec 24))
;; (define (sdat-request-method       vec)    (vector-ref  vec 25))
;; (define (sdat-session-cookie       vec)    (vector-ref  vec 26))
;; (define (sdat-curr-err             vec)    (vector-ref  vec 27))
;; (define (sdat-log-port             vec)    (vector-ref  vec 28))
;; (define (sdat-logfile              vec)    (vector-ref  vec 29))
;; (define (sdat-seen-pages           vec)    (vector-ref  vec 30))
;; (define (sdat-page-dir-style       vec)    (vector-ref  vec 31))
;; (define (sdat-debugmode            vec)    (vector-ref  vec 32))
;; (define (sdat-shared-hash          vec)    (vector-ref  vec 33))
;; (define (sdat-script               vec)    (vector-ref  vec 34))
;; (define (sdat-force-ssl            vec)    (vector-ref  vec 35))
;; 
;; (define (session:get-shared vec varname)
;;   (hash-table-ref/default (vector-ref vec 33) varname #f))
;; 
;; (define (sdat-dbtype-set!              vec val)(vector-set! vec 0 val))
;; (define (sdat-dbinit-set!              vec val)(vector-set! vec 1 val))
;; (define (sdat-conn-set!                vec val)(vector-set! vec 2 val))
;; (define (sdat-params-set!              vec val)(vector-set! vec 3 val))
;; (define (sdat-path-set-params!         vec val)(vector-set! vec 4 val))
;; (define (sdat-session-set-key!         vec val)(vector-set! vec 5 val))
;; (define (sdat-session-set-id!          vec val)(vector-set! vec 6 val))
;; (define (sdat-domain-set!              vec val)(vector-set! vec 7 val))
;; (define (sdat-toppage-set!             vec val)(vector-set! vec 8 val))
;; (define (sdat-page-set!                vec val)(vector-set! vec 9 val))
;; (define (sdat-curr-set-page!           vec val)(vector-set! vec 10 val))
;; (define (sdat-content-set-type!        vec val)(vector-set! vec 11 val))
;; (define (sdat-page-set-type!           vec val)(vector-set! vec 12 val))
;; (define (sdat-sroot-set!               vec val)(vector-set! vec 13 val))
;; (define (sdat-twikidir-set!            vec val)(vector-set! vec 14 val))
;; (define (sdat-pagedat-set!             vec val)(vector-set! vec 15 val))
;; (define (sdat-alt-set-page-dat!        vec val)(vector-set! vec 16 val))
;; (define (sdat-pagevars-set!            vec val)(vector-set! vec 17 val))
;; (define (sdat-pagevars-set-before!     vec val)(vector-set! vec 18 val))
;; (define (sdat-sessionvars-set!         vec val)(vector-set! vec 19 val))
;; (define (sdat-sessionvars-set-before!  vec val)(vector-set! vec 20 val))
;; (define (sdat-globalvars-set!          vec val)(vector-set! vec 21 val))
;; (define (sdat-globalvars-set-before!   vec val)(vector-set! vec 22 val))
;; (define (sdat-logpt-set!               vec val)(vector-set! vec 23 val))
;; (define (sdat-formdat-set!             vec val)(vector-set! vec 24 val))
;; (define (sdat-request-set-method!      vec val)(vector-set! vec 25 val))
;; (define (sdat-session-set-cookie!      vec val)(vector-set! vec 26 val))
;; (define (sdat-curr-set-err!            vec val)(vector-set! vec 27 val))
;; (define (sdat-log-set-port!            vec val)(vector-set! vec 28 val))
;; (define (sdat-logfile-set!             vec val)(vector-set! vec 29 val))
;; (define (sdat-seen-set-pages!          vec val)(vector-set! vec 30 val))
;; (define (sdat-page-set-dir-style!      vec val)(vector-set! vec 31 val))
;; (define (sdat-debugmode-set!           vec val)(vector-set! vec 32 val))
;; (define (sdat-shared-set-hash!         vec val)(vector-set! vec 33 val))
;; (define (sdat-script-set!              vec val)(vector-set! vec 34 val))
;; (define (sdat-force-set-ssl!           vec val)(vector-set! vec 35 val))
;; 
;; (define (session:set-shared! vec varname val)
;;   (hash-table-set! (vector-ref vec 33) varname val))

;; The global session
(define s:session (make-sdat))

;; SPLIT INTO STRAIGHT FORWARD INIT AND COMPLEX INIT
#;(define (session:initialize self #!optional (configf #f))
  (sdat-dbtype-set! self      'pg)
  (sdat-page-set! self        "home")        ;; these are defaults
  (sdat-curr-set-page! self   "home")
  (sdat-content-set-type! self "Content-type: text/html; charset=iso-8859-1\n\n")
  (sdat-page-set-type! self   'html)
  (sdat-toppage-set! self     "index")
  (sdat-params-set! self      '())           ;;
  (sdat-path-set-params! self '())
  (sdat-session-set-key! self #f)
  (sdat-pagedat-set! self     '())
  (sdat-alt-set-page-dat! self #f)
  (sdat-sroot-set! self       "./")
  (sdat-session-set-cookie! self #f)
  (sdat-curr-set-err! self #f)
  (sdat-log-set-port! self (current-error-port))
  (sdat-seen-set-pages! self '())
  (sdat-page-set-dir-style! self #t) ;; #t : pages/<pagename>_(view|cntl).scm
                                      ;; #f : pages/<pagename>/(view|control).scm 
  (sdat-debugmode-set!          self #f)
  			     
  (sdat-pagevars-set!           self (make-hash-table))
  (sdat-sessionvars-set!        self (make-hash-table))
  (sdat-globalvars-set!         self (make-hash-table))
  (sdat-pagevars-set-before!    self (make-hash-table))
  (sdat-sessionvars-set-before! self (make-hash-table))
  (sdat-globalvars-set-before!  self (make-hash-table))
  (sdat-domain-set!             self "locahost")   ;; end of defaults
  (sdat-script-set!             self #f)
  (sdat-force-set-ssl!          self #f)
  (let* ((rawconfigdat (session:read-config self configf))
	 (configdat (if rawconfigdat (eval rawconfigdat) '()))
	 (sroot     (s:find-param 'sroot    configdat))
	 (logfile   (s:find-param 'logfile  configdat))
	 (dbtype    (s:find-param 'dbtype   configdat))
	 (dbinit    (s:find-param 'dbinit   configdat))
	 (domain    (s:find-param 'domain   configdat))
	 (twikidir  (s:find-param 'twikidir configdat))
	 (page-dir  (s:find-param 'page-dir-style configdat))
	 (debugmode (s:find-param 'debugmode configdat))
         (script    (s:find-param 'script    configdat))
	 (force-ssl (s:find-param 'force-ssl configdat)))
    (if sroot    (sdat-sroot-set!    self sroot))
    (if logfile  (sdat-logfile-set!  self logfile))
    (if dbtype   (sdat-dbtype-set!   self dbtype))
    (if dbinit   (sdat-dbinit-set!   self dbinit))
    (if domain   (sdat-domain-set!   self domain))
    (if twikidir (sdat-twikidir-set! self twikidir))
    (if debugmode (sdat-debugmode-set! self debugmode))
    (if script    (sdat-script-set!    self script))
    (if force-ssl (sdat-force-set-ssl! self force-ssl))
    (sdat-page-set-dir-style! self page-dir)
    ;; (print "configdat: ")(pp configdat)
    (if debugmode
	(session:log self "sroot: " sroot " logfile: " logfile " dbtype: " dbtype 
		     " dbinit: " dbinit " domain: " domain " page-dir-style: " page-dir))
    )
  (sdat-shared-set-hash! self (make-hash-table))
  )

;; Used for the strangely inconsistent handling of the config file. A better way is needed.
;;
;;   (let ((dbtype (sdat-dbtype self)))
;;     (print "dbtype: " dbtype)
;;     (sdat-dbtype-set! self (eval dbtype))))

(define (session:setup self #!optional (configf #f))
  (session:initialize self configf)
  (let ((dbtype    (sdat-dbtype self))
	(debugmode (sdat-debug-mode self))
	(dbinit    (eval (sdat-dbinit self)))
	(dbexists  #f))
    (let ((dbfname (alist-ref 'dbname dbinit)))
      (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))
		(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)))
      (if debugmode (session:log self "dbtype: " dbtype " dbfname: " dbfname " dbexists: " dbexists)))
    (sdat-conn-set! self (dbi:open dbtype dbinit))
    (set! *db* (sdat-conn self))
    (if (and (not dbexists)(eq? dbtype 'sqlite3))
 	(begin
	  (print "WARNING: Setting up session db with sqlite3")
	  (session:setup-db self)))
    (session:process-url-path self)
    (session:setup-session-key self)
    ;; capture stdin if this is a POST
    (sdat-request-method-set! self (get-environment-variable "REQUEST_METHOD"))
    (sdat-formdat-set! self (formdat:load-all))))

;; setup the db with session tables, works for sqlite only right now
(define (session:setup-db self)
  (let ((conn (sdat-conn self)))
    (for-each 
     (lambda (stmt)
       (dbi:exec conn stmt))
     (list "CREATE TABLE session_vars (id INTEGER PRIMARY KEY,session_id INTEGER,page TEXT,key TEXT,value TEXT);"
	   "CREATE TABLE sessions (id INTEGER PRIMARY KEY,session_key TEXT,last_used TIMESTAMP);"
           "CREATE TABLE metadata (id INTEGER PRIMARY KEY,key TEXT,value TEXT);"))))
;;  ;; if we have a session_key look up the session-id and store it
;;  (sdat-session-set-id! self (session:get-id self)))

;; only set session-cookie when a new session is created
(define (session:setup-session-key self)  
  (let* ((sk  (session:extract-session-key self))
         (sid (if sk (session:get-id self sk) #f)))
    (if (not sid) ;; need a new key
        (let* ((new-key (session:get-new-key self))
               (new-sid (session:get-id self new-key)))
          (sdat-session-key-set! self new-key)
          (sdat-session-id-set! self new-sid)
          (sdat-session-cookie-set! self (session:make-cookie self)))
        (sdat-session-id-set! self sid))))

(define (session:make-cookie self)
  ;; (list (conc "session_key=" (sdat-session-key self) "; Path=/; Domain=." (sdat-domain self) "; Max-Age=" (* 86400 14) "; Version=1"))) 
  ;; According to 
  ;;    http://www.codemarvels.com/2010/11/apache-rewriterule-set-a-cookie-on-localhost/

  ;;  Here are the 2 (often left out) requirements to set a cookie using
  ;;  httpd-F�s rewrite rule (mod_rewrite), while working on localhost:-A
  ;;
  ;;  Use the IP 127.0.0.1 instead of localhost/machine-name as the
  ;;  domain; e.g. [CO=someCookie:someValue:127.0.0.1:2:/], which says
  ;;  create a cookie -Y�someCookie� with value �someValue� for the
  ;;  domain �127.0.0.1$B!m(B having a life time of 2 mins, for any path in
  ;;  the domain (path=/). (Obviously you will have to run the
  ;;  application with this value in the URL)
  ;;
  ;;  To make a session cookie, limit the flag statement to just three
  ;;  attributes: name, value and domain. e.g
  ;;  [CO=someCookie:someValue:127.0.0.1] %G–%@ Any further
  ;;  settings, apache writes an� expires� attribute for the set-cookie
  ;;  header, which makes the cookie a persistent one (not really
  ;;  persistent, as the expires value set is the current server time
  ;;  %G–%@ so you don-F-F�t even get to see your cookie!)-A
  (list (string-substitute 
	 ";" "; " 
	 (car (construct-cookie-string 
	       ;; warning! messing up this itty bitty bit of code will cost much time!
	       `(("session_key" ,(sdat-session-key self)
		  expires: ,(+ (current-seconds) (* 14 86400)) 
		  ;; max-age: (* 14 86400)
		  path: "/" ;; 
		  domain: ,(string-append "." (sdat-domain self))
		  version: 1)) 0)))))

;; look up a given session key and return the id if found, #f if not found
(define (session:get-id self session-key)
  ;; (let ((session-key (sdat-session-key self)))
  (if session-key
      (let ((query (string-append "SELECT id FROM sessions WHERE session_key='" session-key "'"))
            (conn (sdat-conn self))
            (result #f))
	(dbi:for-each-row 
	 (lambda (tuple)
	   (set! result (vector-ref tuple 0)))
	 conn query)
	(if result (dbi:exec conn (conc "UPDATE sessions SET last_used=" (dbi:now conn) " WHERE session_key=?;") session-key))
        result)
      #f))

;; 
(define (session:process-url-path self)
  (let ((path-info    (get-environment-variable "PATH_INFO"))
	(query-string (get-environment-variable "QUERY_STRING")))
    ;; (session:log self "path-info=" path-info " query-string=" query-string)
    (if path-info
	(let* ((parts    (string-split path-info "/"))
	       (numparts (length parts)))
	  (if (> numparts 0)
	      (sdat-page-set! self (car parts)))
	  ;; (session:log self "url-path=" url-path " parts=" parts)
	  (if (> numparts 1)
	      (sdat-path-params-set! self (cdr parts)))
          (if query-string
              (sdat-params-set! self (string-split query-string "&")))))))

;; BUGGY!
(define (session:get-new-key self)
  (let ((conn   (sdat-conn self))
        (tmpkey (session:make-rand-string 20))
        (status #f))
    (dbi:for-each-row (lambda (tuple)
			(set! status #t))
		      conn (string-append "INSERT INTO sessions (session_key) VALUES ('" tmpkey "')"))
    tmpkey))

;; returns session key IFF it is in the HTTP_COOKIE 
(define (session:extract-session-key self)
  (let ((http-cookie (get-environment-variable "HTTP_COOKIE")))
    ;; (err:log "http-cookie: " http-cookie)
    (if http-cookie
        (session:extract-key-from-param self (string-split-fields  ";\\s+" http-cookie infix:) "session_key")
        #f)))

(define (session:get-session-id self session-key)
  (let ((query "SELECT id FROM sessions WHERE session_key=?;")
        (result #f))
    ;;     (pg:query-for-each (lambda (tuple)
    ;;                          (set! result (vector-ref tuple 0))) ;; (vector-ref tuple 0)))
    ;;                        (s:sqlparam query session-key)
    ;;                        (sdat-conn self))
    ;;                        conn)
    (dbi:for-each-row (lambda (tuple)
			(set! result (vector-ref tuple 0))) ;; (vector-ref tuple 0)))
		      (sdat-conn self)
		      (s:sqlparam query session-key))
    result))

;; delete all records for a session
;; 
;; NEEDS TO BE TRANSACTIONIZED!
;;
(define (session:delete-session self session-key)
  (let ((session-id (session:get-session-id self session-key))
        (qry1        ;; (conc "BEGIN;"
			  "DELETE FROM session_vars WHERE session_id=?;")
	(qry2             "DELETE FROM sessions WHERE id=?;")
		     ;;  "COMMIT;"))
        (conn              (sdat-conn self)))
    (if session-id
        (begin
          (dbi:exec conn qry1 session-id) ;; session-id)
	  (dbi:exec conn qry2 session-id)
	  ;; (session:initialize self)
	  (session:setup self)))
    (not (session:get-session-id self session-key))))

;; (define (session:delete-session self session-key)
;;   (let ((session-id (session:get-session-id self session-key))
;;         (queries    (list "BEGIN;"
;; 			  "DELETE FROM session_vars WHERE session_id=?;"
;;                           "DELETE FROM sessions WHERE id=?;"
;; 			  "COMMIT;"))
;;         (conn              (sdat-conn self)))
;;     (if session-id
;;         (begin
;;           (for-each
;;            (lambda (query)
;;              (dbi:exec conn query session-id))
;; 	   queries)
;; 	  (initialize self '())
;; 	  (session:setup self)))
;;     (not (session:get-session-id self session-key))))

(define (session:extract-key self key)
  (let ((params (sdat-params self)))
    (session:extract-key-from-param self params key)))

(define (session:extract-key-from-param self params key)
  (let ((r1     (regexp (string-append "^" key "=([^=]+)$"))))
    (err:log "INFO: Looking for " key " in " params)
    (if (< (length params) 1) #f
	(let loop ((head   (car params))
		   (tail   (cdr params)))
	  (let ((match (string-match r1 head)))
	    (cond
	     (match
	      (let ((session-key (list-ref match 1)))
		(err:log "INFO: Found session key=" session-key)
		(sdat-session-key-set! self (list-ref match 1))
		session-key))
	     ((null? tail)
	      #f)
	     (else
	      (loop (car tail)
		    (cdr tail)))))))))

(define (session:set-page! self page_name)
  (sdat-page-set! self page_name))

(define (session:close self)
  (dbi:close (sdat-conn self)))
;; (close-output-port (sdat-logpt self))

(define (session:err-msg self msg)
  (hash-table-set! (sdat-sessionvars self) "ERROR_MSG"
		   (string-intersperse (map s:any->string msg) " ")))

(define (session:prev-err self)
  (let ((prev-err (hash-table-ref/default (sdat-sessionvars-before self) "ERROR_MSG" #f))
	(curr-err (hash-table-ref/default (sdat-sessionvars self) "ERROR_MSG" #f)))
    (if prev-err prev-err
	(if curr-err curr-err #f))))

;; session vars
;; 1. keys are always a string NOT a symbol
;; 2. values are always a string conversion is the responsibility of the 
;;    consuming function (at least for now, I'd like to change this)

;; set a session var for the current page
;;
(define (session:curr-page-set! self key value)
  (hash-table-set! (sdat-pagevars self) (s:any->string key) (s:any->string value)))

;; del a var for the current page
;;
(define (session:page-var-del! self key)
  (hash-table-delete! (sdat-pagevars self) (s:any->string key)))

;; get the appropriate hash given a page "*sessionvars*, *globalvars* or page
;;
(define (session:get-page-hash self page)
  (if (string=? page "*sessionvars*")
      (sdat-sessionvars self)
      (if (string=? page "*globalvars*")
	  (sdat-globalvars self)
	  (sdat-pagevars self))))

;; set a session var for a given page
;;
(define (session:set! self page key value)
  (let ((ht (session:get-page-hash self page)))
    (hash-table-set! ht (s:any->string key) (s:any->string value))))

;; get session vars for the current page
;;
(define (session:page-get self key)
  (hash-table-ref/default (sdat-pagevars self) key #f))

;; get session vars for a specified page
;;
(define (session:get self page key params)
  (let* ((ht  (session:get-page-hash self page))
	 (res (hash-table-ref/default ht (s:any->string key) #f)))
    (session:apply-type-preference res params)))

;; delete a session var for a specified page
;;
(define (session:del! self page key)
  (let ((ht (session:get-page-hash self page)))
    (hash-table-delete! ht (s:any->string key))))

;; get ALL keys for this page and store in the session pagevars hash
;;
(define (session:get-vars self)
  (let ((session-id  (sdat-session-id self)))
    (if (not session-id)
	(err:log "ERROR: No session id in session object! session:get-vars")
	(let* ((result             #f)
	       (conn               (sdat-conn self))
	       (pagevars-before    (sdat-pagevars-before self))
	       (sessionvars-before (sdat-sessionvars-before self))
	       (globalvars-before  (sdat-globalvars-before self))
	       (pagevars           (sdat-pagevars self))
	       (sessionvars        (sdat-sessionvars self))
	       (globalvars         (sdat-globalvars self))
	       (page-name          (sdat-page self))
	       (session-key        (sdat-session-key self))
	       (query              (string-append
				    "SELECT key,value FROM session_vars INNER JOIN sessions ON session_vars.session_id=sessions.id "
				    "WHERE session_key=? AND page=?;")))
	  ;; first the page specific vars
	  (dbi:for-each-row (lambda (tuple)
			      (let ((k (vector-ref tuple 0))
				    (v (vector-ref tuple 1)))
				(hash-table-set! pagevars-before k v)
				(hash-table-set! pagevars        k v)))
			    conn
			    (s:sqlparam query session-key page-name))
	  ;; then the session specific vars
	  (dbi:for-each-row (lambda (tuple)
			      (let ((k (vector-ref tuple 0))
				    (v (vector-ref tuple 1)))
				(hash-table-set! sessionvars-before k v)
				(hash-table-set! sessionvars        k v)))
			    conn
			    (s:sqlparam query session-key "*sessionvars*"))
	  ;; and finally the global vars
	  (dbi:for-each-row (lambda (tuple)
			      (let ((k (vector-ref tuple 0))
				    (v (vector-ref tuple 1)))
				(hash-table-set! globalvars-before k v)
				(hash-table-set! globalvars        k v)))
			    conn
			    (s:sqlparam query session-key "*globalvars"))
	  ))))

(define (session:save-vars self)
  (let ((session-id  (sdat-session-id self)))
    (if (not session-id)
	(err:log "ERROR: No session id in session object! session:get-vars")
	(let* ((status      #f)
	       (conn        (sdat-conn self))
	       (page-name   (sdat-page self))
	       (del-query   "DELETE FROM session_vars WHERE session_id=? AND page=? AND key=?;")
	       (ins-query   "INSERT INTO session_vars (session_id,page,key,value) VALUES(?,?,?,?);")
	       (upd-query   "UPDATE session_vars set value=? WHERE key=? AND session_id=? AND page=?;")
	       (changed-count 0))
	  ;; save the delta only
	  (for-each
	   (lambda (page) ;; page is: "*globalvars*" "*sessionvars*" or otherstring
	     (let* ((before-after-ht (cond
				      ((string=? page "*sessionvars*")
				       (vector (sdat-sessionvars self)
					       (sdat-sessionvars-before self)))
				       ((string=? page "*globalvars*")
					(vector (sdat-globalvars self)
						(sdat-globalvars-before self)))
				       (else 
					(vector (sdat-pagevars self)
						(sdat-pagevars-before self)))))
		    (master-ht   (vector-ref before-after-ht 0))
		    (before-ht   (vector-ref before-after-ht 1))
		    (master-keys (hash-table-keys master-ht))
		    (before-keys (hash-table-keys before-ht))
		    (all-keys (delete-duplicates (append master-keys before-keys))))
	       (for-each 
		(lambda (key)
		  (let ((master-value (hash-table-ref/default master-ht key #f))
			(before-value (hash-table-ref/default before-ht key #f)))
		    (cond
		     ;; before and after exist and value unchanged - do nothing
		     ((and master-value before-value (equal? master-value before-value)))
		     ;; before and after exist but are changed
		     ((and master-value before-value)
		      (dbi:for-each-row (lambda (tuple)
					  (set! changed-count (+ changed-count 1)))
					conn
					(s:sqlparam upd-query master-value key session-id page)))
		     ;; master-value no longer exists (i.e. #f) - remove item
		     ((not master-value)
		      (dbi:for-each-row (lambda (tuple)
					  (set! changed-count (+ changed-count 1)))
					conn
					(s:sqlparam del-query session-id page key)))
		     ;; before-value doesn't exist - insert a new value
		     ((not before-value)
		      (dbi:for-each-row (lambda (tuple)
					  (set! changed-count (+ changed-count 1)))
					conn
					(s:sqlparam ins-query session-id page key master-value)))
		     (else (err:log "Shouldn't get here")))))
		all-keys))) ;; process all keys
	   (list "*sessionvars*" "*globalvars*" page-name))))))

;; (pg:sql-null-object? element)
(define (session:read-config self #!optional (fname #f))
  (let* ((cgi-path (pathname-directory (car (argv))))
         (name     (or fname (string-append (if cgi-path (conc cgi-path "/") "") "." (pathname-file (car (argv))) ".config"))))
    (if (not (file-exists? name))
	(print name " not found at " (current-directory))
	(let* ((fp (open-input-file name))
	       (initargs (read fp)))
	  (close-input-port fp)
	  initargs))))

;; call the controller if it exists
;; 
;; WARNING - this code needs a defense agains recursive calling!!!!!
;;
;;   I suggest a limit of 100 calls. Plenty for allowing multiple instances
;;   of a page inside another page. 
;;
;; parts = 'both | 'control | 'view
;;

(define (files-read->string . files)
  (string-intersperse 
   (apply append (map file-read->string files)) "\n"))

(define (file-read->string f) 
  (let ((p (open-input-file f)))
    (let loop ((hed (read-line p))
	       (res '()))
      (if (eof-object? hed)
	  res
	  (loop (read-line p)(append res (list hed)))))))

(define (process-port p)
  (let ((e (interaction-environment)))
    (map 
     (lambda (x)
       (cond
	((list? x) x)
	((string? x) x)
	(else '())))
     (port-map (lambda (s)
		 (eval s e))
	       (lambda ()(read p))))))

(define (session:process-file f)
  (let* ((p    (open-input-file f))
	 (dat  (process-port p)))
    (close-input-port p)
    dat))

;; May 2011, putting all pages into one directory for the following reasons:
;;   1. want filename to reflect page name (emacs limitation)
;;   2. that's it! no other reason. could make it configurable ...
;; page-dir-style is:
;;  'stored   => stored in executable
;;  'flat     => pages flat directory
;;  'dir      => directory tree pages/<pagename>/{view,control}.scm
;; parts:
;;  'both     => load control and view (anything other than view or control and the default)
;;  'view     => load view only
;;  'control  => load control only
(define (session:call-parts self page #!key (parts 'both))
  (sdat-curr-page-set! self page)
  (let* ((dir-style    (sdat-page-dir-style self));; (equal? (sdat-page-dir-style self) "onedir")) ;; flag #t for onedir, #f for old style
	 (dir          (string-append (sdat-sroot self) 
				      (if dir-style 
					  (conc "/pages/")
					  (conc "/pages/" page)))))
    (case dir-style
      ;; NB// Stored always loads both control and view
      ((stored)
       ((eval (string->symbol (conc "pages:" page))) 
	self                         ;; the session
	(sdat-conn self)         ;; the db connection
	(sdat-shared-hash self)  ;; a shared hash table for passing data to/from page calls
	))
      ((flat)   
       (let* ((so-file  (conc dir page ".so"))
	      (scm-file (conc dir page ".scm"))
	      (src-file (or (file-exists? so-file)
			    (file-exists? scm-file))))
	 (if src-file
	     (begin
	       (load src-file)
	       ((eval (string->symbol (conc "pages:" page))) 
		self                         ;; the session
		(sdat-conn self)         ;; the db connection
		(sdat-shared-hash self)  ;; a shared hash table for passing data to/from page calls
		))
	     (list "<p>Page not found " page " </p>"))))
       ;; first the control
       ;; (let ((control-file (conc "pages/" page "_ctrl.scm"))
       ;;       (view-file    (conc "pages/" page "_view.scm")))
       ;;   (if (and (file-exists? control-file)
       ;;  	  (not (eq? parts 'view)))
       ;;       (begin
       ;;         (session:set-called! self page)
       ;;         (load control-file)))
       ;;   (if (file-exists? view-file)
       ;;       (if (not (eq? parts 'control))
       ;;  	 (session:process-file view-file))
       ;;       (list "<p>Page not found " page " </p>")))
      ((dir) "ERROR:  dir style not yet re-implemented")
      (else
       (list "ERROR: page-dir-style must be stored, dir or flat, got " dir-style)))))

(define (session:call self page parts)
  (session:call-parts self page 'both))

(define (session:load-model self model)
  (let* ((mpath     (session:model-path self))
	 (model.scm (string-append mpath "/" model ".scm"))
	 (model.so  (string-append mpath "/" model ".so")))
    (if (file-exists? model.so)
	(load model.so)
	(if (file-exists? model.scm)
	    (load model.scm)
	    (s:log "ERROR: model " model.scm " not found")))))

(define (session:model-path self)
  (or (sdat-models self)
      (string-append (sdat-sroot self) "/models/")))

(define (session:pp-formdat self)
  (let ((dat (formdat:all->strings (sdat-formdat self))))
    (string-intersperse dat "<br> ")))

(define (session:param->string params)
  ;; (err:log "params=" params)
  (if (< (length params) 1)
      ""
      (let loop ((key (car params))
		 (val (cadr params))
		 (tail (cddr params))
		 (result '()))
	(let ((newresult (cons (string-append (s:any->string key) "=" (s:any->string val))
			       result)))
	  (if (< (length tail) 1) ;; true if done
	      (string-intersperse newresult "&")
	      (loop (car tail)(cadr tail)(cddr tail) newresult))))))

(define (session:link-to self page params)
  (let* ((https-host   (get-environment-variable "HTTPS_HOST"))
         (force-ssl    (sdat-force-ssl self))
	 (server       (or https-host ;; Assuming HTTPS_HOST is only set if available
			   (get-environment-variable "HTTP_HOST")
			   (get-environment-variable "SERVER_NAME")
			   (sdat-domain self)))
         (force-script  (sdat-script self))
	 (script        (or force-script
			    (let ((script-name (string-split (get-environment-variable "SCRIPT_NAME") "/")))
			      (if (> (length script-name) 1)
				  (string-append (car script-name) "/" (cadr script-name))
				  (get-environment-variable "SCRIPT_NAME"))))) ;; build script name from first two elements. This is a hangover from before I used ? in the URL.)
         (session-key   (sdat-session-key self))
	 (paramstr      (session:param->string params)))
    (session:log self "server=" server " script=" script " page=" page)
    (string-append (if (or https-host force-ssl)
		      "https://"
		      "http://")
		   server "/" script "/" page "?" paramstr))) ;; "/sn=" session-key)))

(define (session:cgi-out self)
  (let* ((content  (list (sdat-content-type self))) ;; '("Content-type: text/html; charset=iso-8859-1\n\n"))
	 (header   (let ((cookie (sdat-session-cookie self)))
		     (if cookie
			 (cons (string-append "Set-Cookie: " (car cookie))
			       content)
			 content)))
	 (pagedat  (sdat-pagedat self)))
    (s:cgi-out 
     (cons header pagedat))))

(define (session:log self . msg)
  (with-output-to-port (sdat-log-port self) ;; (sdat-logpt self)
    (lambda () 
      (apply print msg))))

;; escape, convert or return raw when given user input data that potentially
;; could be malicious
;;
(define (session:apply-type-preference res params)
  (let* ((dtype    (if (null? params)
		       'escaped
		       (car params)))
	 (tags    (if (null? params)
		      '()
		      (cdr params))))
    (case dtype
      ((raw)     res)
      ((number)  (if (string? res)(string->number res) #f))
      ((escaped) (if (string? res)
		     (s:html-filter->string res tags)
		     res))
      ((escaped-nl) (if (string? res) ;; escape \n and \r
			(string-intersperse
			 (string-split
			  (string-intersperse
			   (string-split (s:html-filter->string res tags) "\n")
			   "\\n")
			  "\r")
			 "\\r")
			res)) ;; should return #f if not a string and can't escape it?
      (else      (if (string? res)
		     (s:html-filter->string res '())
		     res)))))

#;(define (session:get-param-from params key)
  (let ((r1 (regexp (conc "^" (s:any->string key) "=(.*)$"))))
    (if (null? params) #f
        (let loop ((head (car params))
                   (tail (cdr params)))
          (let ((match (string-match r1 head)))
            (if match
                (list-ref match 1)
                (if (null? tail) #f
                    (loop (car tail)(cdr tail)))))))))

;; params are stored as list of key=val
;;
(define (session:get-param self key type-params)
  ;; (session:log s:session "params=" (slot-ref s:session 'params))
  (let* ((params (sdat-params self))
	 (res    (session:get-param-from params key)))
    (session:apply-type-preference res type-params)))

;; This one will get the first value found regardless of form
;; param: (dtype [tag1 tag2 ...])
;; dtype:
;;    'raw     : do no conversion
;;    'number  : convert to number, return #f if fails
;;    'escaped : use html-escape to protect the input -- this is the default
;;
(define (session:get-input self key params)
  (let* ((dtype    (if (null? params)
		       'escaped
		       (car params)))
	 (tags    (if (null? params)
		      '()
		      (cdr params)))
	 (formdat (sdat-formdat self))
	 (res     (if (not formdat) #f
		      (if (or (string? key)(number? key)(symbol? key))
			  (if (and (vector? formdat)
				   (eq? (vector-length formdat) 1)
				   (hash-table? (vector-ref formdat 0)))
			      (formdat:get formdat key)
			      (begin
				(session:log self "ERROR: formdat: " formdat " is not of class <formdat>")
				#f))
			  (begin
			    (session:log self "ERROR: bad key " key)
			    #f)))))
    (case dtype
      ((raw)     res)
      ((number)  (if (string? res)(string->number res) #f))
      ((escaped) (if (string? res)
		     (s:html-filter->string res tags)
		     res))
      (else      (if (string? res)
		     (s:html-filter->string res '())
		     res)))))

;; This one will get the first value found regardless of form
(define (session:get-input-keys self)
  (let* ((formdat (sdat-formdat self)))
    (if (not formdat) #f
	(if (and (vector? formdat)
		 (eq? (vector-length formdat) 1)
		 (hash-table? (vector-ref formdat 0)))
	    (formdat:keys formdat)
	    (begin
	      (session:log self "ERROR: formdat: " formdat " is not of class <formdat>")
	      #f)))))

(define (session:run-actions self)
  (let* ((action    (session:get-param self 'action '(raw)))
	 (page      (sdat-page self)))
    ;; (print "action=" action " page=" page)
    (if action
	(let ((action-lst  (string-split action ".")))
	  ;; (print "action-lst=" action-lst)
	  (if (not (= (length action-lst) 2)) 
	      (err:log "Action should be of form: module.action")
	      (let* ((targ-page   (car action-lst))
		     (proc-name   (string-append targ-page "-action"))
		     (targ-action (cadr action-lst)))
		;; (err:log "targ-page=" targ-page " proc-name=" proc-name " targ-action=" targ-action)

		;; call here only if never called before
		(if (session:never-called-page? self targ-page)
		    (session:call-parts self targ-page 'control))
		;;                    proc                         action    

		(if #t ;; set to #t to see better error messages during debuggin :-)
		    ((eval (string->symbol proc-name)) targ-action) ;; unsafe execution
		    (condition-case ((eval (string->symbol proc-name)) targ-action)
				    ((exn file) (s:log "file error"))
				    ((exn i/o)  (s:log "i/o error"))
				    ((exn )     (s:log "Action not implemented: " proc-name " action: " targ-action))
				    (var ()     (s:log "Unknown Error"))))))))))

(define (session:never-called-page? self page)
  (session:log self "Checking for page: " page)
  (not (member page (sdat-seen-pages self))))

(define (session:set-called! self page)
  (sdat-seen-pages-set! self (cons page (sdat-seen-pages self))))

;;======================================================================
;; Alternative data type delivery
;;======================================================================

(define (session:alt-out self)
  (let ((dat (sdat-alt-page-dat self)))
    ;; (s:log "dat is: " dat)
    ;; (print "HTTP/1.1 200 OK")
    (print "Date: " (time->string (seconds->utc-time (current-seconds))))
    (print "Content-Type: " (sdat-content-type self))
    (print "Accept-Ranges: bytes")
    (print "Content-Length: " (if (blob? dat)
				  (blob-size dat)
				  0))
    (print "Keep-Alive: timeout=15, max=100")
    (print "Connection: Keep-Alive")
    (print "")
    (write-string (blob->string dat) #f (current-output-port))))

;;======================================================================
;; Orphaned functions
;;======================================================================

;; was in setup
;;
(define (s:log . msg)
  (apply session:log s:session msg))


;; Usage: (s:get-err s:big)
(define (s:get-err wrapperfunc)
  (let ((errmsg (sdat-curr-err s:session)))
    (if errmsg ((if wrapperfunc
                    wrapperfunc
                    s:strong) errmsg) '())))
(define (stml:cgi-session session #!optional (configf #f))
  ;; (session:initialize session)
  (session:setup session configf)
  (session:get-vars session)

  (sdat-log-port-set! session ;; (current-error-port))
		      (open-output-file (sdat-logfile session) #:append))
  (s:validate-inputs)
  (change-directory (sdat-sroot session))
  (session:run-actions session)
  (sdat-pagedat-set! session
		     (append (sdat-pagedat session)
			     (s:call (sdat-toppage session))))
  (if (eq? (sdat-page-type session) 'html) ;; default is html. 
      (session:cgi-out session)
      (session:alt-out session))
  (session:save-vars session)
  (session:close session))


(define (s:validate-inputs)
  (if (not (s:validate-uri))
      (begin (s:error-page "Bad URI" (let ((ref (get-environment-variable "HTTP_REFERER")))
				       (if ref
					   (list "referred from" ref)
					   "")))
	     (exit))))

(define (s:error-page . err)
  (s:cgi-out (cons "Content-type: text/html; charset=iso-8859-1\n\n"
		   (s:html (s:head 
			    (s:title err)
			    (s:body
			     (s:h1 "ERROR")
			     (s:p err)))))))           


(define (stml:main proc #!optional (configf #f))
  (handle-exceptions
   exn   
   (if (sdat-debug-mode s:session)
       (begin
	 (print "Content-type: text/html")
	 (print "")
	 (print "<html> <head> <title>EXCEPTION</title> </head> <body>")
	 (print "   QUERY_STRING is: <b> " (get-environment-variable "QUERY_STRING") " </b> <br>")
	 (print "<pre>")
	 ;; (print "   EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
	 (print-error-message exn)
	 (print-call-chain)
	 (print "</pre>")
	 (print "<table>")
	 (for-each (lambda (var)
		     (print "<tr><td>" (car var) "</td><td>" (cdr var) "</td></tr>"))
		   (get-environment-variables))
	 (print "</table>")
	 (print "</body></html>"))
       (begin
	 (with-output-to-file (conc "/tmp/stml-crash-" (current-process-id) ".log")
	   (lambda ()
	     (print "EXCEPTION")
	     (print "   QUERY_STRING is: " (get-environment-variable "QUERY_STRING") )
	     (print "")
	     ;; (print "   EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
	     (print-error-message exn)
	     (print-call-chain)
	     (print "")
	     (for-each (lambda (var)
			 (print (car var) "\t" (cdr var)))
		       (get-environment-variables))))
	 ;; return something useful to the user
	 (print "Content-type: text/html")
	 (print "")
	 (print "<html> <head> <title>EXCEPTION</title> </head> <body>")
	 (print "<h1>CRASH!</h1>")
	 (print "   Please notify support at " (sdat-domain s:session) " that the error log is stml-crash-" (current-process-id) ".log</b> <br>")
	 ;; (print "<pre>")
	 ;; ;; (print "   EXCEPTION: " ((condition-property-accessor 'exn 'message) exn))
	 ;; ;; (print-error-message exn)
	 ;; ;; (print-call-chain)
	 ;; (print "</pre>")
	 ;; (print "<table>")
	 ;; (for-each (lambda (var)
	 ;; 	     (print "<tr><td>" (car var) "</td><td>" (cdr var) "</td></tr>"))
	 ;; 	   (get-environment-variables))
	 ;; (print "</table>")
	 (print "</body></html>")))
   (if proc (proc s:session) (stml:cgi-session s:session configf))
 ;; (raise-error)
 ;; (exit)
   ))

;; find out if we are in debugmode
(define (s:debug-mode?)
  (sdat-debug-mode s:session))

(define (s:never-called-page? page)
  (session:never-called-page? s:session page))

(define (s:set-err . args)
  (sdat-curr-err-set! s:session args))

(define (s:current-page)
  (sdat-page s:session))

(define (s:delete-session)
  (session:delete-session s:session (sdat-session-key s:session)))

(define (s:call page . partsl)
  (if (null? partsl)
      (session:call s:session page #f)
      (session:call s:session page (car partsl))))

(define (s:link-to page . params)
  (session:link-to s:session page params))

(define (s:get-param key . type-params)
  (session:get-param s:session key type-params))

;; these are page local
(define (s:get key) 
  (session:page-get s:session key))

(define (s:set! key val)
  (session:curr-page-set! s:session key val))

(define (s:del! key)
  (session:page-var-del! s:session key))

#;(define (s:get-n-del! key)
  (let ((val (session:page-get s:session key)))
    (session:del! s:session val key)
    val))

;; these are session wide
(define (s:session-var-get key . params) 
  (session:get s:session "*sessionvars*" key params))

(define (s:session-var-set! key val)
  (session:set! s:session "*sessionvars*" key val))

(define (s:session-var-get-n-del! key)
  (let ((val (session:page-get s:session key)))
     (session:del! s:session "*sessionvars*" key)
     val))

(define (s:session-var-del! key)
  (session:del! s:session "*sessionvars*" key))

(define s:session-var-delete! s:session-var-del!)

;; utility to get all vars as hash table
(define (s:session-get-sessionvars)
  (sdat-sessionvars s:session))

;;======================================================================
;; Sugar
;;======================================================================
;;
;; (require 'syntax-case)
;; 
;; (define-syntax s:if-param
;;   (syntax-rules ()
;;     [(_ s x)   (if (s:get s) x (s:comment "s:if not"))]
;;     [(_ s x y) (if (s:get s) x y)]))
;; ;; 
;; (define-syntax s:if-test
;;   (syntax-rules ()
;;     [(_ s x) (if   (string=? "yep" s)   x (list "s:if not"))]
;;     [(_ s x y) (if (string=? "yep" s) x y)]))

;; Some of these routines use:
;;
;;     http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html
;;
;; Syntax for defining macros in a simple style similar to function definiton,
;;  when there is a single pattern for the argument list and there are no keywords.
;;
;; (define-simple-syntax (name arg ...) body ...)
;;

(define-syntax define-simple-syntax
  (syntax-rules ()
    ((_ (name arg ...) body ...)
     (define-syntax name (syntax-rules () ((name arg ...) (begin body ...)))))))

;;======================================================================
;; syntatic sugar items
;;======================================================================

;; We often seem to want to include stuff if a conditional is met
;; otherwise not include it. This routine makes that slightly cleaner
;; since using a pure if results in #<undefined> objects. (admittedly they 
;; should be ignored but this is slightly cleaner I think). 
;;
;; NOTE: This has to be a macro or the true clause will be evaluated 
;; whether "a" is true or false

;; If a is true return b, else return '()
(define-simple-syntax (s:if a b)
  (if a b '()))


;; Using the Simple-Syntax System
;; 
;; The syntax for defining macros in this system is similar to that for defining functions. In fact if the macro has a fixed number of arguments the syntax is identical. For example:
;; 
;;   ; Define a simple macro to add a value to a variable.
;;   ;
;;   (define-simple-syntax (+= variable value)
;;     (set! variable (+ variable value)))
;; 
;;   ; Use it.
;;   ;
;;   (define v 2)
;;   (+= v 7)
;;   v ; => 9
;; 
;; For a fixed number of arguments followed by an unknown number of arguments we use ... after a single argument to represent the unknown number (possibly zero) of arguments. For example, let's revise our definition of += to allow zero or more values to be added:
;; 
;;   ; Define a simple macro to add a zero or more values to a variable
;;   ;
;;   (define-simple-syntax (+= variable value ...)
;;     (set! variable (+ variable value ...)))
;; 
;;   ; Use it
;;   ;
;;   (define v 2)
;;   (+= v 7)
;;   v ; => 9
;;   (+= v 3 4)
;;   v ; => 16
;;   (+= v)
;;   v ; => 16
;; 

(define-simple-syntax (s:if-param varname first ...)
  (if (s:get varname)
      (begin
	first
	...)
      '()))

(define-simple-syntax (s:if-sessionvar varname first ...)
  (if (s:session-var-get varname)
      (begin
	first
	...)
      '()))

;; (define-macro (s:if-param varname ...)
;;   (match dat
;; 	 (()    '())
;; 	 ((a)    `(if (s:get ,varname) ,a '()))
;; 	 ((a b)  `(if (s:get ,varname) ,a ,b))))
;; 
;; (define-macro (s:if-sessionvar varname . dat)
;;   (match dat
;; 	 (()    '())
;; 	 ((a)    `(if (s:session-var-get ,varname) ,a '()))
;; 	 ((a b)  `(if (s:session-var-get ,varname) ,a ,b))))
;; 

)








Added stml2/stml2.setup version [54bbd223c3].




































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2010, 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 FITNlmESS FOR A PARTICULAR
;;  PURPOSE.

;;;; margs.setup

;; compile the code into a dynamically loadable shared object
;; (will generate margs.so)
;; (compile -s margs.scm)

;; Install as extension library

;; handle cookies
(standard-extension 'cookie       "0.5")
;; (standard-extension 'stmlcommon   "0.5")
(standard-extension 'stml2        "0.5")

;; (standard-extension 'session      "0.5")
;; (standard-extension 'misc-stml    "0.5") ;; moved to stmlcommon.scm
;; (standard-extension 'html-filter  "0.5") ;; moved to stmlcommon.scm
;; (standard-extension 'formdat      "0.5") ;; moved into stmlcommon.scm
;; (standard-extension 'setup        "0.5") ;; moved into stmlcommon.scm
;; (standard-extension 'keystore     "0.5") ;; moved into stmlcommon.scm
;; (standard-extension 'sqltbl       "0.5") ;; eliminated

;; (install-extension 'stml "stml.so")









Added stml2/stmlcommon.scm version [d0639f2742].
























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.

;; (require-extension syntax-case)
;; (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)

)








Added stml2/stmlmodule.scm version [296e0e34a7].


















1
2
3
4
5
6
7
8
9
10
11
12
13
14

+
+
+
+
+
+
+
+
+
+
+
+
+
+

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

;; (require-extension syntax-case)
;; (declare (run-time-macros))

(include "stmlcommon.scm")









Added stml2/stmlrun.scm version [a5be661fee].























1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

#!/usr/local/bin/csi -q

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

;; (require-extension syntax-case)
;; (declare (run-time-macros))

;; (include "stmlcommon.scm")
(require-library stml)


(stml:main #f)








Added stml2/sugar.scm version [b784df1be7].





















































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

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

;;======================================================================
;; Sugar
;;======================================================================
;;
;; (require 'syntax-case)
;; 
;; (define-syntax s:if-param
;;   (syntax-rules ()
;;     [(_ s x)   (if (s:get s) x (s:comment "s:if not"))]
;;     [(_ s x y) (if (s:get s) x y)]))
;; ;; 
;; (define-syntax s:if-test
;;   (syntax-rules ()
;;     [(_ s x) (if   (string=? "yep" s)   x (list "s:if not"))]
;;     [(_ s x y) (if (string=? "yep" s) x y)]))

;; Some of these routines use:
;;
;;     http://www.cs.toronto.edu/~gfb/scheme/simple-macros.html
;;
;; Syntax for defining macros in a simple style similar to function definiton,
;;  when there is a single pattern for the argument list and there are no keywords.
;;
;; (define-simple-syntax (name arg ...) body ...)
;;

(define-syntax define-simple-syntax
  (syntax-rules ()
    ((_ (name arg ...) body ...)
     (define-syntax name (syntax-rules () ((name arg ...) (begin body ...)))))))

;;======================================================================
;; syntatic sugar items
;;======================================================================

;; We often seem to want to include stuff if a conditional is met
;; otherwise not include it. This routine makes that slightly cleaner
;; since using a pure if results in #<undefined> objects. (admittedly they 
;; should be ignored but this is slightly cleaner I think). 
;;
;; NOTE: This has to be a macro or the true clause will be evaluated 
;; whether "a" is true or false

;; If a is true return b, else return '()
(define-simple-syntax (s:if a b)
  (if a b '()))


;; Using the Simple-Syntax System
;; 
;; The syntax for defining macros in this system is similar to that for defining functions. In fact if the macro has a fixed number of arguments the syntax is identical. For example:
;; 
;;   ; Define a simple macro to add a value to a variable.
;;   ;
;;   (define-simple-syntax (+= variable value)
;;     (set! variable (+ variable value)))
;; 
;;   ; Use it.
;;   ;
;;   (define v 2)
;;   (+= v 7)
;;   v ; => 9
;; 
;; For a fixed number of arguments followed by an unknown number of arguments we use ... after a single argument to represent the unknown number (possibly zero) of arguments. For example, let's revise our definition of += to allow zero or more values to be added:
;; 
;;   ; Define a simple macro to add a zero or more values to a variable
;;   ;
;;   (define-simple-syntax (+= variable value ...)
;;     (set! variable (+ variable value ...)))
;; 
;;   ; Use it
;;   ;
;;   (define v 2)
;;   (+= v 7)
;;   v ; => 9
;;   (+= v 3 4)
;;   v ; => 16
;;   (+= v)
;;   v ; => 16
;; 

(define-simple-syntax (s:if-param varname first ...)
  (if (s:get varname)
      first
      ...))

(define-simple-syntax (s:if-sessionvar varname first ...)
  (if (s:session-var-get varname)
      first
      ...))

;; (define-macro (s:if-param varname ...)
;;   (match dat
;; 	 (()    '())
;; 	 ((a)    `(if (s:get ,varname) ,a '()))
;; 	 ((a b)  `(if (s:get ,varname) ,a ,b))))
;; 
;; (define-macro (s:if-sessionvar varname . dat)
;;   (match dat
;; 	 (()    '())
;; 	 ((a)    `(if (s:session-var-get ,varname) ,a '()))
;; 	 ((a b)  `(if (s:session-var-get ,varname) ,a ,b))))
;; 








Added stml2/test.scm version [62a996e095].


























1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

(use test md5)

(require-extension sqlite3)
(import (prefix sqlite3 sqlite3:))

(require-library dbi)

;; (declare (uses stml))

(include "requirements.scm")
(include "cookie.scm")
(include "misc-stml.scm")
(include "formdat.scm")
(include "stml.scm")
(include "session.scm")
(include "sqltbl.scm")
(include "html-filter.scm")
(include "keystore.scm")

(define p (open-input-file "test.stml"))
(print (process-port p))
(close-input-port p)








Added stml2/test.stml version [0f6611f558].














1
2
3
4
5
6
7
8
9
10

+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2008, Matthew Welland. Kiatoa.com All rights reserved.
;; 
;; index

(list
 (s:html
  (s:head
   (s:title "Kiatoa")
   (s:link  'rel "stylesheet" 'type "text/css" 'href "/kiatoa/markup.css")
   (s:link  'rel "stylesheet" 'type "text/css" 'href "/kiatoa/layout.css"))))








Added stml2/tests/example.post.binary.in version [a9df00433e].

cannot compute difference between binary files




Added stml2/tests/example.post.in version [459133135e].





1

+

email-address=matt%3A1&password=Blah&form-name=login








Added stml2/tests/models/test.scm version [d92e100cbc].















1
2
3
4
5
6
7
8
9
10
11

+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2008, 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.
;;

;; models/test.scm








Added stml2/tests/pages/test/control.scm version [3d3e9e16d3].















1
2
3
4
5
6
7
8
9
10
11

+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2008, 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.
;;

;; pages/test/control.scm








Added stml2/tests/pages/test/view.scm version [79bce22dd6].















1
2
3
4
5
6
7
8
9
10
11

+
+
+
+
+
+
+
+
+
+
+

;; Copyright 2007-2008, 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.
;;

;; pages/test/view.scm








Added stml2/tests/test.scm version [5b953a7034].





































































































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
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

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

#!/usr/local/bin/csi -q 

;; Copyright 2007-2008, 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.

(use test md5)

(require-extension sqlite3)
(import (prefix sqlite3 sqlite3:))

;; (require-library dbi)
(use (prefix dbi dbi:))

(load "./requirements.scm")
(load "./cookie.scm")
(load "./misc-stml.scm")
(load "./formdat.scm")
(load "./stml.scm")
(load "./session.scm")
(load "./sqltbl.scm")
(load "./html-filter.scm")
(load "./keystore.scm")

;; Test the primitive dbi interface

(system "rm -f tests/test.db")
(define db (dbi:open 'sqlite3 '((dbname . "tests/test.db"))))
(dbi:exec db "CREATE TABLE foo(id INTEGER PRIMARY KEY,name TEXT);")
(dbi:exec db "INSERT INTO foo(name) VALUES(?);" "Matt")
(dbi:for-each-row 
 (lambda (tuple)
   (print (vector-ref tuple 0) " " (vector-ref tuple 1)))
 db "SELECT * FROM foo;")
(test "dbi:get-one" "Matt" (dbi:get-one db "SELECT name FROM foo WHERE name='Matt';"))

;; keystore
(dbi:exec db "CREATE TABLE metadata (id INTEGER PRIMARY KEY,key TEXT,value TEXT);")

(keystore:set! db "SCHEMA-VERSION" 1.2)
(test "Keystore get" "1.2"  (keystore:get  db "SCHEMA-VERSION"))
(keystore:del! db "SCHEMA-VERSION") 
(test "Keystore get deleted" #f (keystore:get db "SCHEMA-VERSION"))

(system "rm -f tests/test.db")

;; create a session to work with")
(setenv "REQUEST_URI" "/stmlrun?action=test.test")
(setenv "SCRIPT_NAME" "/cgi-bin/stmlrun")
(setenv "PATH_INFO" "/test")
(setenv "QUERY_STRING" "action=test.test")
(setenv "SERVER_NAME" "localhost")
(setenv "REQUEST_METHOD" "GET")

(load "./setup.scm")

(s:validate-inputs)

;; test session variables

(session:get-vars s:session)
(define nada "andnndhhshaas")
(s:session-var-set! "nick" nada)
(test "Session var set/get" nada  (s:session-var-get "nick"))
(print "got here")
(session:save-vars s:session)
(session:get-vars  s:session)
(test "Session var set/get after save/get" nada (s:session-var-get "nick"))
(session:del! s:session "*sessionvars*" "nick")
(test "Session var del"                    #f   (s:session-var-get "nick"))
(session:save-vars s:session)
(session:get-vars s:session)
(s:session-var-set! "nick" nada)
(session:save-vars s:session)

;; (test "Session var del"                    #f   (s:session-var-get "nick"))

;; test person

(load "./tests/models/test.scm")

(print "Session key is " (sdat-get-session-key s:session))

(test "Delete session" #t (s:delete-session))

(let ((fh (open-input-pipe "ls ./tests/pages/*/control.scm")))
  (let loop ((l (read-line fh)))
    (if (not (eof-object? l))
        (begin
          ;; (print "loading " l)
          (load l)
          (loop (read-line fh)))))
  (close-input-port fh))

;; Should have poll:poll defined now.
(test "Make a random string" 2 (string-length (session:make-rand-string 2)))
(test "Create an encrypted password using DES (backwards compat)" "abQ9KY.KfrYrc" (s:crypt-passwd "foo" "ab"))
(test "Create an encrypted password using Blowfish" "$2a$12$GyoKHX/UOxMLGtwdSTr7EOF9KQzlyyyRqFTKx1YvLA3sMukbV4WBC" (s:crypt-passwd "foo" "$2a$12$GyoKHX/UOxMLGtwdSTr7EO"))

(test "s:any->string on a hash-table" "#<hash-table>" (s:any->string (make-hash-table)))

(define select-list
  '((a b c)(d (e f g)(h i j #t))))
(define result '("<SELECT name=\"efg\">" 
		 ((("<OPTION label=\"a\" value=\"b\">c</OPTION>") 
		   ("<OPTGROUP label=d" 
		    ("<OPTION label=\"e\" value=\"f\">g</OPTION>")
		    ("<OPTION  selected label=\"h\" value=\"i\">j</OPTION>") 
		    "</OPTGROUP>")))
		 "</SELECT>"))

(test "Select list" result (s:select select-list 'name "efg"))

;; Test modules

(test "misc:non-zero-string \"\"" #f (misc:non-zero-string ""))
(test "misc:non-zero-string #f" #f (misc:non-zero-string #f))
(test "misc:non-zero-string 'blah" #f (misc:non-zero-string 'blah))

;; forms
(define form #f)
(test "make <formdat>" #t (let ((f (make-formdat:formdat)))
			    (set! form f)
			    #t))
(test "formdat: set!/get" "Yep!" (begin
				   (formdat:set! form "blah" "Yep!")
				   (formdat:get  form "blah")))

(test "s:string->pgint"   123 (s:any->pgint "123"))
(test "s:illegal-pgint (legal)"        #f (s:illegal-pgint 1011))
(test "s:illegal-pgint (illegal big)"   1 (s:illegal-pgint  9999999999))
(test "s:illegalpgint (illegal small)" -1 (s:illegal-pgint -9999999999))

;; The twiki module

;; clean up
(system "rm -rf twikis/*")
(load "modules/twiki/twiki-mod.scm")
(define keys (list "blah" 1 'nada))
(test "twiki:keys->key"  "blah 1 nada" (twiki:keys->key keys))
(define key (twiki:keys->key keys))

(define *tdb* #f)
(test "twiki:open-db"   #t (let ((db (twiki:open-db key)))
			     (set! *tdb* db)
			     (if *tdb* #t #f)))
(define wiki (make-twiki:wiki))
(twiki:wiki-set-wid! wiki 1)
(twiki:wiki-set-name! wiki "main")
(twiki:wiki-set-perms! wiki '(r w))

(test "twiki:dat->html" '("Hello" "<BR>") (twiki:dat->html "Hello" wiki))
(test "twiki:keys->fname" '("twikis/Ymxha/CAxIG/5hZGE" "YmxhaCAxIG5hZGE_") ;; ("twikis/d99a2de9/6808493b/23770f70" "d99a2de96808493b23770f70c76dffe4")
      (twiki:key->fname key))

(test "twiki:name->wid"     1     (twiki:name->wid *tdb* "main"))
(test "twiki:get-tiddlers-by-num" '() (twiki:get-tiddlers-by-num  *tdb* 0 (list 1 2 3)))
(test "twiki:get-tiddlers-by-name" '() (twiki:get-tiddlers-by-name *tdb* 0 "MainMenu"))
(test "twiki:get-tiddlers"  '()  (twiki:get-tiddlers *tdb* 0 (list "MainMenu")))
(test "twiki:get-tiddlers"  '()  (twiki:get-tiddlers *tdb* 0 (list "MainMenu" "AnotherOne")))
(test "twiki:wiki" "<TABLE>"     (car (twiki:wiki "main" (list "blah" 1 'nada))))
(test "twiki:view"  "<DIV class=\"node\">" (car (twiki:view "" "" 0 (twiki:tiddler-make) wiki)))

(test "s:td"              '("<TD>" (()) "</TD>") (s:td '()))
;; (test "twiki:get-tiddlers-by-name" '() (twiki:get-tiddlers-by-name 1 "fred"))
(test "twiki:tiddler-name->id" 1 (twiki:tiddler-name->id *tdb* "MainMenu"))
(test "s:set! a var to #f"     ""
      (begin (s:set! "BLAH" #f)
	     (s:get "BLAH"))) ;; don't know if this one makes sense. Setting to #f should really delete the value
(test "twiki:save-dat"           2        (twiki:save-dat *tdb* "dat" 0))
(test "twiki:get-dat"            "dat"    (twiki:get-dat *tdb* 2))
(test "twiki:get-dat"            #f       (twiki:get-dat *tdb* 5))
;; (test "twiki:get-dat"      #f    (twiki:get-dat *tdb* #f))
(test "twiki:save-tiddler"       #t       (twiki:save-tiddler *tdb* "heading" "body" "tags" key 0))
;; (test "twiki:save-curr-tiddler"  #f       (twiki:save-curr-tiddler *tdb* 1))
(test "twiki:edit-twiddler"      #t       (list? (twiki:edit-tiddler *tdb* key 0 0)))
(test "twiki:maint_area"         "<DIV>"  (car (twiki:maint_area *tdb* 1 key wiki)))
(test "twiki:pic_mgmt"           "<DIV>"  (car (twiki:pic_mgmt *tdb* 1 key)))

;; get a blob jpg to process
(define inp2 (open-input-file "tests/kiatoa.png"))
(define dat  (string->blob (read-string #f inp2)))
(close-input-port inp2)


(test "twiki:save-pic"           #t       (twiki:save-pic *tdb* (list "mypic.jpg" "image/jpeg" dat) 0)) ;; (string->blob "testing eh!")))) 
;; (test "twiki:save-pic-from-form" #f       (twiki:save-pic-from-form *tdb* 1))

;; more tests on dats

(define dat #f)
(let ((inp (open-input-file "tests/kiatoa.png")))
  (set! dat (read-string #f inp))
  (close-input-port inp))
(use md5)
(define dat-md5 (md5:digest dat))
(test "twiki:save-dat (binary)" 4        (twiki:save-dat *tdb* dat 1))
(test "twiki:get-dat (binary)"  dat-md5  (let ((d (twiki:get-dat *tdb* 4)))
					   (md5:digest d)))
;; forms
;; (define inp (open-input-file "tests/example.post.in"))
;; (define dat (read-string #f inp))
;; (define datstr (open-input-string dat))

;; binary inputs
(define inp (open-input-file "tests/example.post.binary.in"))
(define dat #f)

(test "formdat:load-all-port multipart" #t (let ((idat (formdat:load-all-port inp)))
				   (set! dat idat)
				   #t))
(test "formdat:keys" '(picture-name input-picture "" submit-picture) (formdat:keys dat))

(define inp (open-input-file "tests/example.post.in"))
(test "formdat:load-all-port single part" #t (let ((idat (formdat:load-all-port inp)))
				   (set! dat idat)
				   #t))
(test "formdat:keys" '(email-address form-name password) (formdat:keys dat))

(close-input-port inp)








Added stml2/testscript.sh version [48d4209584].











1
2
3
4
5
6
7

+
+
+
+
+
+
+

export REQUEST_URI='/stmlrun?action=login.login'
export SCRIPT_NAME=/cgi-bin/stmlrun
export PATH_INFO=/classifieds
export QUERY_STRING='action=login.login'
export SERVER_NAME=localhost
export REQUEST_METHOD=GET
export HTTP_COOKIE='session_key=to09ipFJ9_2KXT96b2f9Q'








Modified tests.scm
from [52d412173f]
to [bf1af44b82].




︙


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

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








-
-
-
-










+
+
+
+
+








;;
;;======================================================================

;;======================================================================
;; Tests
;;======================================================================

(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
(import (prefix sqlite3 sqlite3:))
(require-library stml)

(declare (unit tests))
(declare (uses lock-queue))
(declare (uses db))
(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))

(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking tcp directory-utils)
(import (prefix sqlite3 sqlite3:))
(import stml2)

(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
(include "js-path.scm")




︙


789
790
791
792
793
794
795
796

797
798
799
800



801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
































836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855



















856
857
858
859
860
861


862
863
864
865


866
867
868


869
870

871
872
873
874
875
876


877
878
879


880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903





















904
905
906


907
908
909
910
911
912
913

790
791
792
793
794
795
796

797
798



799
800
801
802
803
804
































805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837



















838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860


861
862
863
864


865
866
867


868
869
870

871
872
873
874
875


876
877
878


879
880
881
882
883





















884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905


906
907
908
909
910
911
912
913
914








-
+

-
-
-
+
+
+



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

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




-
-
+
+


-
-
+
+

-
-
+
+

-
+




-
-
+
+

-
-
+
+



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

-
-
+
+










;; tests:genrate dashboard body 
;;

(define (tests:dashboard-body page pg-size keys numkeys  total-runs linktree area-name get-prev-links get-next-links flag run-patt target-patt)
  (let* ((start (* page pg-size)) 
	       ;(runsdat   (rmt:get-runs "%" pg-size start (map (lambda (x)(list x "%")) keys)))
					;(runsdat   (rmt:get-runs "%" pg-size start (map (lambda (x)(list x "%")) keys)))
         (runsdat   (rmt:get-runs-by-patt  keys run-patt target-patt start pg-size #f 0 sort-order: "desc"))
                    ; db:get-runs-by-patt   keys runnamepatt targpatt offset limit fields last-update   
	       (header    (vector-ref runsdat 0))
	       (runs      (vector-ref runsdat 1))
					; db:get-runs-by-patt   keys runnamepatt targpatt offset limit fields last-update   
	 (header    (vector-ref runsdat 0))
	 (runs      (vector-ref runsdat 1))
         (ctr 0)
         (test-runs-hash (tests:get-rest-data runs header numkeys))
         (test-list (hash-table-keys test-runs-hash))) 
  
  (s:html tests:css-jscript-block (tests:css-jscript-block-cond flag)
		   (s:title "Summary for " area-name)
		   (s:body 'onload "addEvents();"
                          (get-prev-links page linktree)
                          (get-next-links page linktree total-runs)
                           
			   (s:h1 "Summary for " area-name)
                           (s:h3 "Filter" )
                           (s:input 'type "text"  'name "testname" 'id "testname" 'length "30" 'onkeyup "filtersome()")
			   ;; top list
         
			   (s:table 'id "LinkedList1" 'border "1" 'cellspacing 0
                            (map (lambda (key)
				 (let* ((res (s:tr 'class "something" 
				  (s:th key )
                                   (map (lambda (run)
                                   (s:th  (vector-ref run ctr)))
                                  runs))))
                             (set! ctr (+ ctr 1))
                               res))
                               keys)
                               (s:tr
				 (s:th "Run Name")
                                  (map (lambda (run)
                                   (s:th (db:get-value-by-header run header "runname")))
                                  runs))
                              
                               (map (lambda (test-name)
                                 (let* ((item-hash (hash-table-ref/default test-runs-hash test-name  #f))
                                         (item-keys (sort (hash-table-keys item-hash) string<=?))) 
                                          (map (lambda (item-name)  
    
    (s:html tests:css-jscript-block (tests:css-jscript-block-cond flag)
	    (s:title "Summary for " area-name)
	    (s:body 'onload "addEvents();"
		    (get-prev-links page linktree)
		    (get-next-links page linktree total-runs)
		    
		    (s:h1 "Summary for " area-name)
		    (s:h3 "Filter" )
		    (s:input 'type "text"  'name "testname" 'id "testname" 'length "30" 'onkeyup "filtersome()")
		    ;; top list
		    
		    (s:table 'id "LinkedList1" 'border "1" 'cellspacing 0
			     (map (lambda (key)
				    (let* ((res (s:tr 'class "something" 
						      (s:th key )
						      (map (lambda (run)
							     (s:th  (vector-ref run ctr)))
							   runs))))
				      (set! ctr (+ ctr 1))
				      res))
				  keys)
			     (s:tr
			      (s:th "Run Name")
			      (map (lambda (run)
				     (s:th (db:get-value-by-header run header "runname")))
				   runs))
			     
			     (map (lambda (test-name)
				    (let* ((item-hash (hash-table-ref/default test-runs-hash test-name  #f))
					   (item-keys (sort (hash-table-keys item-hash) string<=?))) 
				      (map (lambda (item-name)  
  		                             (let* ((res (s:tr  'class item-name
				                         (s:td  item-name 'class "test" )
                                                           (map (lambda (run)
                                                               (let* ((run-test (hash-table-ref/default item-hash item-name  #f))
                                                                      (run-id (db:get-value-by-header run header "id"))
                                                                      (result (hash-table-ref/default run-test run-id "n/a"))
                                                                      ;(relative-path (get-relative-path)) 
                                                                      (status (if (string? result)
									                                                            	result
										                                                            (car result)))
                                                                        (link (if (string? result)
										                                                            result
                                                                                (if (equal? flag #t) 
                                                                                (s:a (car result) 'href (conc "./test_log?runid=" run-id "&testname="  item-name ))
  																																						  (s:a (car result) 'href (string-substitute  (conc linktree "/")  "" (cadr result)  "-"))))))
                                                                       (s:td  link 'class status)))
                                                                runs))))
                                                        res))
                                                   item-keys)))
                               test-list)))))) 
								(s:td  item-name 'class "test" )
								(map (lambda (run)
								       (let* ((run-test (hash-table-ref/default item-hash item-name  #f))
									      (run-id (db:get-value-by-header run header "id"))
									      (result (hash-table-ref/default run-test run-id "n/a"))
					;(relative-path (get-relative-path)) 
									      (status (if (string? result)
											  result
											  (car result)))
									      (link (if (string? result)
											result
											(if (equal? flag #t) 
											    (s:a (car result) 'href (conc "./test_log?runid=" run-id "&testname="  item-name ))
											    (s:a (car result) 'href (string-substitute  (conc linktree "/")  "" (cadr result)  "-"))))))
									 (s:td  link 'class status)))
								     runs))))
					       res))
					   item-keys)))
				  test-list)))))) 

;; (tests:create-html-tree "test-index.html")
;;
(define (tests:create-html-tree outf)
   (let* ((lockfile  (conc outf ".lock"))
	 			 (runs-to-process '())
  (let* ((lockfile  (conc outf ".lock"))
	 (runs-to-process '())
         (linktree  (common:get-linktree))
         (area-name (common:get-testsuite-name))
	  		 (keys      (rmt:get-keys))
	  		 (numkeys   (length keys))
	 (keys      (rmt:get-keys))
	 (numkeys   (length keys))
         (run-patt (or (args:get-arg "-run-patt")
                        (args:get-arg "-runname")
                        "%"))
		       (args:get-arg "-runname")
		       "%"))
         (target (or  (args:get-arg "-target-patt") 
											(args:get-arg "-target")
		      (args:get-arg "-target")
                      "%"))
         (targlist (string-split target "/"))
         (numtarg  (length targlist))  
         (targtweaked (if (> numkeys numtarg)
			   								(append targlist (make-list (- numkeys numtarg) "%"))
			  								targlist))
			  (append targlist (make-list (- numkeys numtarg) "%"))
			  targlist))
         (target-patt (string-join targtweaked "/"))
         ;(total-runs  (rmt:get-num-runs "%")) ;;this needs to be changed to filter by target
          (total-runs (rmt:get-runs-cnt-by-patt run-patt target-patt keys )) 
					;(total-runs  (rmt:get-num-runs "%")) ;;this needs to be changed to filter by target
	 (total-runs (rmt:get-runs-cnt-by-patt run-patt target-patt keys )) 
         (pg-size 10))
    (if (common:simple-file-lock lockfile)
        (begin
         ;(print total-runs)    
        (let loop ((page 0))
	(let* ((oup       (open-output-file (or outf (conc linktree "/page" page ".html"))))
               (get-prev-links (lambda (page linktree )   
                            (let* ((link  (if (not (eq? page 0))
                                   (s:a "&lt;&lt;prev" 'href (conc  "page" (- page 1) ".html"))
                                   (s:a "" 'href (conc   "page"  page ".html")))))
                               link)))
               (get-next-links (lambda (page linktree total-runs)   
                            (let* ((link  (if (> total-runs (+ 10 (* page pg-size)))
                                   (s:a "next&gt;&gt;" 'href (conc  "page"  (+ page 1) ".html"))
                                   (s:a "" 'href (conc   "page" page  ".html")))))
                               link))) )
          (print "total runs: " total-runs) 
          (s:output-new
	   			 oup
	   					(tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #f run-patt target-patt)) ;; update this function
          (close-output-port oup)
         ; (set! page (+ 1 page))
          (if (> total-runs (* (+ 1 page) pg-size))
           (loop (+ 1  page)))))
					;(print total-runs)    
	  (let loop ((page 0))
	    (let* ((oup            (open-output-file (or outf (conc linktree "/page" page ".html"))))
		   (get-prev-links (lambda (page linktree )   
				     (let* ((link  (if (not (eq? page 0))
						       (s:a "&lt;&lt;prev" 'href (conc  "page" (- page 1) ".html"))
						       (s:a "" 'href (conc   "page"  page ".html")))))
				       link)))
		   (get-next-links (lambda (page linktree total-runs)   
				     (let* ((link  (if (> total-runs (+ 10 (* page pg-size)))
						       (s:a "next&gt;&gt;" 'href (conc  "page"  (+ page 1) ".html"))
						       (s:a "" 'href (conc   "page" page  ".html")))))
				       link))) )
	      (print "total runs: " total-runs) 
	      (s:output-new
	       oup
	       (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #f run-patt target-patt)) ;; update this function
	      (close-output-port oup)
					; (set! page (+ 1 page))
	      (if (> total-runs (* (+ 1 page) pg-size))
		  (loop (+ 1  page)))))
	  (common:simple-file-release-lock lockfile))
	            
	#f)))
	(begin
	  (debug-print 0 *default-log-port* "Failed to get lock on file outf, lockfile: " lockfile) #f))))


(define (tests:readlines filename)
  (call-with-input-file filename
    (lambda (p)
      (let loop ((line (read-line p))
                 (result '()))




︙










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