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

test.scm now shows examples for all surflets-input-fields.

This commit is contained in:
interp 2003-04-16 12:32:24 +00:00
parent aa6e6aabfc
commit a9f5c6ffa7
2 changed files with 168 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
scheme/httpd/surflets/web-server/root/img/221.gif Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 274 B

235
scheme/httpd/surflets/web-server/root/surflets/test.scm
View File

@ -1,87 +1,188 @@
(define-structure surflet surflet-interface (define-structure surflet surflet-interface
(open scheme-with-scsh (open scheme-with-scsh
surflets surflets
receiving
srfi-1
srfi-13
srfi-14
surflets/utilities surflets/utilities
surflets/callbacks surflets/callbacks
httpd-responses) httpd-responses)
(begin (begin
(define global '()) (define global 0)
(define select (make-select-input-field '("a" "b" "c") #t '(@ (size 2)))) (define selections (cons '("a" "b" "c")
'("Andreas" "Bernd" "Clara")))
(define radio-elements '(1 2 3 "a" *))
(define select (make-annotated-select-input-field
(map make-annotated-sel-if-option
(car selections)
(cdr selections))
#t '(@ (size 2))))
(define select2 (make-select-input-field (car selections)))
(define text (make-text-input-field "yoho"))
(define number (make-number-input-field 23))
(define hidden (make-hidden-input-field "value"))
(define password (make-password-input-field "asdf"))
(define textarea (make-textarea-input-field "This
is
a
test"))
(define radio (make-annotated-radio-input-field-group))
(define radios (map radio radio-elements))
(define checkbox (make-annotated-checkbox-input-field "hooray!"))
(define (result req arg) (define (translate-line-breaks text)
(send-html (let lp ((result '())
`(html (title "Result") (text text))
(body (h2 "Result") (let ((index (string-index text char-set:iso-control)))
(p "Returned via callback with arg" (br) (if index
,(format #f "~s" arg)))))) (lp (cons '(br)
(cons (substring/shared text 0 index) result))
;; +2, as we probably have cr+lf
(substring/shared text (+ index 2)))
(reverse (cons text result))))))
(define (cb-result req arg)
(send-html
`(html (title "Result")
(body (h2 "Result")
(p "Returned via callback with arg" (br)
,(format #f "~s" arg))
(hr)
(p (url "test.scm" "Test again.") (br)
(url "/" "Return to main menu."))))))
(define an-cb (make-annotated-callback cb-result))
(define addr (make-annotated-address))
(define (main req) (define (main req)
(set! global (cons 1 global)) (set! global (+ 1 global))
(let* ((an-cb (make-annotated-callback result)) (let* ((req (send-html/suspend
(addr (make-annotated-address)) (lambda (new-url)
(req (send-html/suspend `(html
(lambda (new-url) (body
`(html (body (h1 "This is from SUrflet") (h1 "This is from SUrflet")
(p "called " ,(length global) " times") (p "called " ,global " times")
(p "Choose an annotated address:" (br) (p "Choose an annotated address:" (br)
(ul (ul
(li (url ,(addr new-url "ab=ba") "ab=ba")) (li (url ,(addr new-url "Eva Gottwald") "ab=ba"))
(li (url ,(addr new-url "be<ta") "be<ta")) (li (url ,(addr new-url "be<ta") "be<ta"))
(li (url ,(addr new-url) "<nothing>")))) (li (url ,(addr new-url) "<nothing>"))))
(p "Or choose an annotated callback" (br) (p "Or choose an annotated callback" (br)
(ul (ul
(li (url ,(an-cb 13) "13")) (li (url ,(an-cb 13) "13"))
(li (url ,(an-cb '(1 2 3)) "'(1 2 3)")) (li (url ,(an-cb '(1 2 3)) "'(1 2 3)"))
(li (url ,(an-cb "hello") "hello")) (li (url ,(an-cb "hello") "hello"))
(li (url ,(an-cb #f) "#f")))) (li (url ,(an-cb #f) "#f"))))
(surflet-form (p "Or choose an input field." (br)
,new-url (surflet-form
POST ,new-url
,select POST
'(input (@ (type "text") (name "TeST"))) (table
,(make-submit-button)) (tr (td "Selection:") (td ,select))
(hr) (tr (td "Selection2:") (td ,select2))
(p (url "/" "Return to main menu.")) (tr (td "Simple text: ") (td ,text))
))))) (tr (td "Number: " ) (td ,number))
(save-k #f) (tr (td "Hidden: " ) (td ,hidden))
(done? #f) (tr (td "Password: " ) (td ,password))
(tr (td "Textarea: " ) (td ,textarea))
(tr (td "Radio:")
(td ,(zip radios
(map (lambda (elem)
(list (format #f "~%~s" elem)
'(nbsp) '(nbsp)))
radio-elements))))
(tr (td "Checkbox:") (td ,checkbox)))
,(make-submit-button) ,(make-reset-button) (br)
,(make-image-button "/img/221.gif")))
(hr)
(p (url "/" "Return to main menu.")))))))
(bindings (get-bindings req)) (bindings (get-bindings req))
(selected (input-field-value select bindings))
(selected2 (input-field-value select2 bindings))
(text-entered (input-field-value text bindings))
(number-entered (input-field-value number bindings))
(hidden-value (input-field-value hidden bindings))
(password-text (input-field-value password bindings))
(textarea-text (input-field-value textarea bindings))
(radio-result (input-field-value (radio #f) bindings))
(checkbox-result (input-field-value checkbox bindings))
(result (result
(cond (cond
((returned-via? addr bindings) => ((returned-via? addr bindings) =>
(lambda (string) (lambda (string)
(format #f "returned via annotated string ~s" string))) (format #f "returned via annotated string ~s" string)))
(else (else
(format #f "~s" bindings))))) (set-text-input-field-value! text text-entered)
(only-select-selected! select selected (cdr selections))
(call-with-current-continuation (only-select-selected! select2 (list selected2) (car selections))
(lambda (k) (if number-entered
(set! save-k k) (set-number-input-field-value! number number-entered))
13)) (set-hidden-input-field-value!
hidden
(set! global (cons 1 global)) (string-append "value" (number->string global)))
(if (not done?) (set-password-input-field-value! password password-text)
(begin (set-textarea-input-field-value! textarea textarea-text)
(send-html/suspend (if radio-result
(lambda (continue) (begin
`(html (body (h1 "Result") (map uncheck-radio-input-field! radios)
(p "called " ,(length global) " times") (check-radio-input-field!
,result (br) (list-ref radios
(url ,continue "show results again") (list-index (lambda (a) (equal? a radio-result))
(hr) radio-elements)))))
(p (url "test.scm" "Test again.") (br) (if checkbox-result
(url "/" "Return to main menu.")))))) (check-checkbox-input-field! checkbox)
(uncheck-checkbox-input-field! checkbox))
(set! done? #t) `(p "Returned via submit" (br)
(save-k 13)) "Bindings were: " ,(format #f "~s" bindings) (br)
(table
(@ (valign "top"))
(tr (td "Selected: ") (td ,(format #f "~s" selected)))
(tr (td "Selected2:") (td ,(format #f "~s" selected2)))
(tr (td "Text entered:") (td ,(format #f "~s" text-entered)))
(tr (td "Number entered:")
(td ,(if number-entered
number-entered
"no valid number")))
(tr (td "Hidden:") (td ,hidden-value))
(tr (td "Plain password:") (td ,password-text ))
(tr (td "Textarea:")
(td #\" ,@(translate-line-breaks textarea-text) #\"))
(tr (td "Radio:") (td ,(format #f "~s" radio-result)))
(tr (td "Checkbox:") (td ,(format #f "~s" checkbox-result)))))
))))
(send-html/finish (set! global (+ 1 global))
`(html (body (h1 "Result 2") (send-html/suspend
(p "called " ,(length global) " times") (lambda (continue)
,(format #f "~s" (get-bindings req)) `(html (body (h1 "Result")
(hr) (p "called " ,global " times")
(p (url "test.scm" "Test again.") (br) ,result (br)
(url "/" "Return to main menu.")))))))) (url ,continue "show results again") (br)
(url ,(make-callback main) "continue testing")
(font (@ (size "small"))
"(Note: This is not a browser history link)")
(hr)
(p (url "test.scm" "Test again.") (br)
(url "/" "Return to main menu."))))))
(send-html/finish
`(html (body (h1 "Result 2")
(p "called " ,global " times")
,(format #f "~s" (get-bindings req))
(hr)
(p (url "test.scm" "Test again.") (br)
(url "/" "Return to main menu.")))))))
(define (only-select-selected! sel-if selected indices)
(for-each (lambda (index)
(unselect-sel-if-option! index sel-if))
(iota (length (cdr selections))))
(for-each (lambda (selected)
(select-sel-if-option!
(list-index (lambda (s) (string=? s selected))
indices)
sel-if))
selected))
)) ))