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 define-record-types
let-opt let-opt
servlets servlets
(subset srfi-1 (zip filter)) (subset srfi-1 (zip filter find make-list))
handle-fatal-error handle-fatal-error
) )
(files simple-servlet-api)) (files simple-servlet-api))

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

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