diff --git a/scheme/httpd/surflets/web-server/root/img/221.gif b/scheme/httpd/surflets/web-server/root/img/221.gif new file mode 100644 index 0000000..a183e4f Binary files /dev/null and b/scheme/httpd/surflets/web-server/root/img/221.gif differ diff --git a/scheme/httpd/surflets/web-server/root/surflets/test.scm b/scheme/httpd/surflets/web-server/root/surflets/test.scm index 10248a7..fdf5f55 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/test.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/test.scm @@ -1,87 +1,188 @@ (define-structure surflet surflet-interface (open scheme-with-scsh surflets + receiving + srfi-1 + srfi-13 + srfi-14 surflets/utilities surflets/callbacks httpd-responses) (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) - (send-html - `(html (title "Result") - (body (h2 "Result") - (p "Returned via callback with arg" (br) - ,(format #f "~s" arg)))))) - + (define (translate-line-breaks text) + (let lp ((result '()) + (text text)) + (let ((index (string-index text char-set:iso-control))) + (if index + (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) - (set! global (cons 1 global)) - (let* ((an-cb (make-annotated-callback result)) - (addr (make-annotated-address)) - (req (send-html/suspend - (lambda (new-url) - `(html (body (h1 "This is from SUrflet") - (p "called " ,(length global) " times") - (p "Choose an annotated address:" (br) - (ul - (li (url ,(addr new-url "ab=ba") "ab=ba")) - (li (url ,(addr new-url "be")))) - (p "Or choose an annotated callback" (br) - (ul - (li (url ,(an-cb 13) "13")) - (li (url ,(an-cb '(1 2 3)) "'(1 2 3)")) - (li (url ,(an-cb "hello") "hello")) - (li (url ,(an-cb #f) "#f")))) - (surflet-form - ,new-url - POST - ,select - '(input (@ (type "text") (name "TeST"))) - ,(make-submit-button)) - (hr) - (p (url "/" "Return to main menu.")) - ))))) - (save-k #f) - (done? #f) + (set! global (+ 1 global)) + (let* ((req (send-html/suspend + (lambda (new-url) + `(html + (body + (h1 "This is from SUrflet") + (p "called " ,global " times") + (p "Choose an annotated address:" (br) + (ul + (li (url ,(addr new-url "Eva Gottwald") "ab=ba")) + (li (url ,(addr new-url "be")))) + (p "Or choose an annotated callback" (br) + (ul + (li (url ,(an-cb 13) "13")) + (li (url ,(an-cb '(1 2 3)) "'(1 2 3)")) + (li (url ,(an-cb "hello") "hello")) + (li (url ,(an-cb #f) "#f")))) + (p "Or choose an input field." (br) + (surflet-form + ,new-url + POST + (table + (tr (td "Selection:") (td ,select)) + (tr (td "Selection2:") (td ,select2)) + (tr (td "Simple text: ") (td ,text)) + (tr (td "Number: " ) (td ,number)) + (tr (td "Hidden: " ) (td ,hidden)) + (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)) + (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 (cond ((returned-via? addr bindings) => (lambda (string) (format #f "returned via annotated string ~s" string))) (else - (format #f "~s" bindings))))) - - (call-with-current-continuation - (lambda (k) - (set! save-k k) - 13)) - - (set! global (cons 1 global)) - (if (not done?) - (begin - (send-html/suspend - (lambda (continue) - `(html (body (h1 "Result") - (p "called " ,(length global) " times") - ,result (br) - (url ,continue "show results again") - (hr) - (p (url "test.scm" "Test again.") (br) - (url "/" "Return to main menu.")))))) - - (set! done? #t) - (save-k 13)) + (set-text-input-field-value! text text-entered) + (only-select-selected! select selected (cdr selections)) + (only-select-selected! select2 (list selected2) (car selections)) + (if number-entered + (set-number-input-field-value! number number-entered)) + (set-hidden-input-field-value! + hidden + (string-append "value" (number->string global))) + (set-password-input-field-value! password password-text) + (set-textarea-input-field-value! textarea textarea-text) + (if radio-result + (begin + (map uncheck-radio-input-field! radios) + (check-radio-input-field! + (list-ref radios + (list-index (lambda (a) (equal? a radio-result)) + radio-elements))))) + (if checkbox-result + (check-checkbox-input-field! checkbox) + (uncheck-checkbox-input-field! checkbox)) + `(p "Returned via submit" (br) + "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 - `(html (body (h1 "Result 2") - (p "called " ,(length global) " times") - ,(format #f "~s" (get-bindings req)) - (hr) - (p (url "test.scm" "Test again.") (br) - (url "/" "Return to main menu.")))))))) + (set! global (+ 1 global)) + (send-html/suspend + (lambda (continue) + `(html (body (h1 "Result") + (p "called " ,global " times") + ,result (br) + (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)) ))