scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Add infrastructure for saving default values in get-results.

This commit is contained in:
interp 2002-11-09 17:17:14 +00:00
parent 5e0e6abcb7
commit fb75cd4efe
2 changed files with 41 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
scheme/httpd/surflets/packages.scm
View File

@ -279,7 +279,7 @@
define-record-types
let-opt
servlets
(subset srfi-1 (zip filter))
(subset srfi-1 (zip filter find make-list))
handle-fatal-error
)
(files simple-servlet-api))

67
scheme/httpd/surflets/simple-surflet-api.scm
View File

@ -13,32 +13,41 @@
(zip (map car assoc-query-list)
(get-results (map cadr assoc-query-list) "Web Query")))
(define (get-results queries title . maybe-update-text)
(let* ((queries (map transform-string-to-query queries))
(update-text (:optional maybe-update-text #f))
(req (send-html/suspend
(lambda (new-url)
`(html
(title ,title)
(body (@ (bgcolor "white"))
(h3 ,(if update-text `(font (@ (color "red")) ,update-text) title))
(servlet-form ,new-url POST
(table ,@(map (lambda (query)
(ask query 'html-table-row))
queries))
,(make-submit-button)))))))
(bindings (get-bindings req)))
(call-with-current-continuation
(lambda (exit)
(map (lambda (query)
(with-fatal-error-handler
(lambda (c m)
(exit
(get-results queries title
(ask query 'bad-input-text))))
(ask query 'value bindings)))
queries)))))
(define (get-results queries title . maybe-update-text+defaults)
(let-optionals maybe-update-text+defaults
((update-text #f)
(defaults (make-list (length queries) #f)))
(let* ((queries (map transform-string-to-query queries))
(req (send-html/suspend
(lambda (new-url)
(generate-simple-servlet-page new-url update-text
title
queries defaults))))
(bindings (get-bindings req))
(queries+values (map (lambda (query)
(cons query (ask query 'value bindings)))
queries))
(bad-query+value (find (lambda (query+value)
(not (cdr query+value)))
queries+values)))
(if bad-query+value
(get-results queries title
(ask (car bad-query+value) 'bad-input-text)
(map cdr queries+values))
(map cdr queries+values)))))
(define (generate-simple-servlet-page new-url update-text title queries defaults)
`(html
(title ,title)
(body (@ (bgcolor "white"))
(h3 ,(if update-text
`(font (@ (color "red")) ,update-text)
title))
(servlet-form ,new-url POST
(table ,@(map (lambda (query default)
(ask query 'html-table-row default))
queries defaults))
,(make-submit-button)))))
;; Post some information on a Web page, wait for continue signal.
(define (inform title . text)
@ -77,7 +86,10 @@
(lambda (message)
(case message
((html-table-row)
(lambda (self)
(lambda (self default)
;; DEFAULT is ignored currently. There is a problem with
;; adding the default-value to an already generated
;; input-field.
`(tr (td ,text) (td ,input-field))))
((value)
(lambda (self bindings)
@ -115,7 +127,8 @@
(lambda (message)
(case message
((html-table-row)
(lambda (self)
(lambda (self default)
;; See note above for default.
`(tr (td ,text)
(td (table (tr
,@(map (lambda (radio choice)