1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
|
;; 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.
;;======================================================================
;; dumbobj helpers
;;======================================================================
;; 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))
|
|
>
>
>
|
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.
;;======================================================================
;; dumbobj helpers
;;======================================================================
(declare (unit misc-stml))
(use regex)
;; 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))
|
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
|
(s:html (s:head
(s:title err)
(s:body
(s:h1 "ERROR")
(s:p err)))))))
(define (s:validate-uri)
(let ((uri (getenv "REQUEST_URI"))
(qrs (getenv "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 (getenv "HTTP_REFERER")))
(if ref
(list "referred from" ref)
"")))
(exit))))
;; anything except a list is converted to a string!!!
(define (s:any->string val)
|
|
|
|
|
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
|
(s:html (s:head
(s:title err)
(s:body
(s:h1 "ERROR")
(s:p err)))))))
(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)
|