Changes In Branch stml2
Through [8b66fa08e7]
Excluding Merge-Ins
This is equivalent to a diff from
cb3c5f2532
to 8b66fa08e7
Added .fossil-settings/ignore-glob version [56afbbd51c].
|
1
2
|
+
+
|
install.cfg
requirements.scm
|
|
Modified Makefile
from [865dfc8355]
to [0ba4186b5a].
| ︙ | | |
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
|
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
|
-
+
-
+
|
#
# Following needed on bluehost (maybe on all 64bit?)
#
# CSC_OPTIONS='-C "-fPIC"' make
#
include install.cfg
SRCFILES = stml.scm misc-stml.scm session.scm sqltbl.scm formdat.scm setup.scm keystore.scm html-filter.scm cookie.scm
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 stml.so
$(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
|
| ︙ | | |
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
|
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
|
-
+
|
# 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 *.o *.so
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`
#
|
Modified cookie.scm
from [49ca0d00a6]
to [d78a525a3a].
| ︙ | | |
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
53
54
55
56
57
58
|
-
+
+
+
+
+
+
+
|
;; <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))
;; (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>
;; <#
|
| ︙ | | |
251
252
253
254
255
256
257
|
257
258
259
260
261
262
263
264
|
+
|
;;;; 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)))
)
|
Modified formdat.scm
from [e7bfc732dd]
to [427854d910].
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
|
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.
(declare (unit formdat))
;; (declare (unit formdat))
(module formdat
*
(import chicken scheme data-structures extras srfi-13 ports )
(use html-filter)
(use regex)
(require-extension srfi-69)
(define formdat:*debug* #f)
;; Old data format was something like this. BUT!
;; Forms do not have names so the hierarcy is
|
| ︙ | | |
343
344
345
346
347
348
349
|
350
351
352
353
354
355
356
357
358
|
+
+
|
;; (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)
|#
)
|
Modified html-filter.scm
from [7dc1b6a3b0]
to [1c2965ad32].
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
|
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.
(declare (unit html-filter))
;; (declare (unit html-filter))
(module html-filter
*
(import chicken scheme data-structures extras srfi-13 ports )
(use misc-stml)
(require-extension regex)
;;
(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)))
|
| ︙ | | |
193
194
195
196
197
198
199
|
200
201
202
203
204
205
206
207
|
+
|
""
(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")
)
|
Modified keystore.scm
from [1e4a5aef9c]
to [ab856615aa].
| ︙ | | |
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
|
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
|
-
+
+
+
+
+
+
+
+
+
|
;; PURPOSE.
;;======================================================================
;; The meta data key store, just a general dumping ground for values
;; only used occasionally
;;======================================================================
(declare (unit keystore))
;; (declare (unit keystore))
(module keystore
*
(import chicken scheme data-structures extras srfi-13 ports )
(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))
)
|
Modified misc-stml.scm
from [116e590e88]
to [7dbf69d08d].
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
|
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
|
-
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
+
+
+
+
+
-
-
+
-
+
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
;; 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))
;; (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:))
;; moved to stmlcommon
;; 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))))))
;; (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:fields->string lst)
(string-join (map symbol->string lst) ","))
(define (s:any->number val)
(cond
((number? val) val)
((string? val) (string->number val))
((symbol? val) (string->number (symbol->string val)))
(define (s:vector-get-field vec field field-list)
(vector-ref vec (s:get-fieldnum field-list field)))
;;======================================================================
;;======================================================================
(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
|
| ︙ | | |
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
|
132
133
134
135
136
137
138
139
140
141
142
143
144
145
|
-
-
-
-
-
-
-
-
-
|
(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))
|
| ︙ | | |
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
|
160
161
162
163
164
165
166
167
168
169
170
171
172
173
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
(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"))
(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)))))))
;; 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
(s:log "REQUEST URI NOT AVAILABLE!")
(let ((p (open-input-pipe "env")))
(let loop ((l (read-line p))
(res '()))
(if (eof-object? l)
(s:log res)
(loop (read-line p)(cons (list l "<BR>") res)))))
#t))))
(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))))
;; 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))
|
| ︙ | | |
306
307
308
309
310
311
312
|
233
234
235
236
237
238
239
240
|
+
|
(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))))))))
)
|
Modified session.scm
from [2b15eaba58]
to [464fa3c6e4].
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
|
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-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))
(use (prefix dbi dbi:))
;; (declare (unit session))
(module session
*
(import chicken scheme data-structures extras srfi-13 ports posix files srfi-1)
(use formdat html-filter misc-stml)
(use (prefix dbi dbi:) srfi-69)
(require-extension regex)
(declare (uses cookie))
(use cookie) ;; (declare (uses cookie))
;; 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
|
| ︙ | | |
761
762
763
764
765
766
767
768
769
770
771
772
773
774
|
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
|
+
+
+
+
+
+
+
+
+
+
+
|
"\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-get-params self))
(res (session:get-param-from params key)))
(session:apply-type-preference res type-params)))
|
| ︙ | | |
866
867
868
869
870
871
872
|
883
884
885
886
887
888
889
890
891
892
893
894
895
896
|
+
+
+
+
+
+
+
|
(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))))
;; was in setup
;;
(define (s:log . msg)
(apply session:log s:session msg))
)
|
Modified setup.scm
from [1b8611c4ba]
to [e8c4330f90].
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
|
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
|
+
+
+
+
+
-
-
+
+
-
-
-
|
;; 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))
(declare (uses session))
;; (declare (unit setup))
;; (declare (uses session))
(require-extension srfi-69)
(require-extension regex)
;; 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))))
(define (s:log . msg)
(apply session:log s:session msg))
|
| ︙ | | |
210
211
212
213
214
215
216
|
212
213
214
215
216
217
218
219
|
+
|
(define (s:never-called-page? page)
(session:never-called-page? s:session page))
;; find out if we are in debugmode
(define (s:debug-mode?)
(sdat-get-debugmode s:session))
)
|
Modified sqltbl.scm
from [29093c83c7]
to [80d836633e].
| ︙ | | |
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
|
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
|
+
+
+
+
+
-
+
|
;; query-params ;; list of params for the query
;; conn ;; connection to db
;; num-rows ;; whatever
;; curr-row-ptr ;; number of the current row
;; curr-row ;; the current row vector (?? do we really want this ??)
;; ))
(module sqltbl
*
(import chicken scheme data-structures extras srfi-13 ports )
(declare (unit sqltbl))
;; (declare (unit sqltbl))
(define (make-sqltbl:tbl)(make-vector 9))
(define (sqltbl:tbl-get-rows vec) (vector-ref vec 0))
(define (sqltbl:tbl-get-fields vec) (vector-ref vec 1))
(define (sqltbl:tbl-get-fields-hash vec) (vector-ref vec 2))
(define (sqltbl:tbl-get-query vec) (vector-ref vec 3))
(define (sqltbl:tbl-get-query-params vec) (vector-ref vec 4))
|
| ︙ | | |
107
108
109
110
111
112
113
|
112
113
114
115
116
117
118
119
|
+
|
;; runs proc on each row and returns the resulting list
(define (sqltbl:map self proc)
(map (lambda (row)
(proc (sqltbl:vector->hash self row))) (sqltbl:tbl-get-rows self)))
)
|
Deleted stml.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."))
|
Deleted stml.scm version [5df99c79b1].
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
|
|
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
|
;; 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))
(declare (uses misc-stml))
(require-extension regex)
;; 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: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:dblquote . args)
(let* ((inputs (s:extract args))
(data (caar inputs))
(params (s:process-params (cadr inputs))))
(conc """ data """)))
(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 otherwise
(define (s:nbsp str)
(if (string-match "^\\s*$" str)
" "
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-get-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) #\ ) (any->string x))))
((list? x)
(s:print (+ indent 1) x))
(else
;; (print "ERROR: Bad input 01") ;; why do anything with junk?
)))
inlst))
(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))))
|
Deleted stml.setup version [b663e1c0bf].
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.
;;;; margs.setup
;; compile the code into a dynamically loadable shared object
;; (will generate margs.so)
;; (compile -s margs.scm)
;; Install as extension library
(install-extension 'stml "stml.so")
|
Added 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.scm version [4a50517b51].