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

+ servlet-handler/admin structure gives runtime 

access to servlet-handler options
+ several constructors for form input fields
This commit is contained in:
interp 2002-09-30 14:43:15 +00:00
parent db6b607d0f
commit 2579598783
2 changed files with 225 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -74,9 +74,16 @@
send ;just send (no finish, no suspend) send ;just send (no finish, no suspend)
)) ))
(define-interface servlet-handler/admin-interface
(export get-loaded-plugins
unload-plugin
set-instance-lifetime!
get-instance-lifetime))
(define-structures (define-structures
((servlet-handler servlet-handler-interface) ((servlet-handler servlet-handler-interface)
(servlet-handler/plugin servlet-handler/plugin-interface)) (servlet-handler/plugin servlet-handler/plugin-interface)
(servlet-handler/admin servlet-handler/admin-interface))
(open httpd-responses (open httpd-responses
httpd-request httpd-request
uri ;URI-PATH-LIST->PATH uri ;URI-PATH-LIST->PATH
@ -96,6 +103,7 @@
defrec-package ;DEFINE-RECORD defrec-package ;DEFINE-RECORD
threads ;SLEEP threads ;SLEEP
thread-fluids ;FORK-THREAD thread-fluids ;FORK-THREAD
sxml-to-html ;SXML->HTML
scsh ;regexp et al. scsh ;regexp et al.
scheme scheme
) )
@ -116,13 +124,17 @@
make-input-field make-input-field
make-upper-input-field make-upper-input-field
make-text-input-field make-text-input-field
make-hidden-input-field
make-password-input-field make-password-input-field
make-number-input-field make-number-input-field
make-textarea-input-field make-textarea-input-field
make-select-input-field make-select-input-fields
make-checkbox-input-field make-checkbox-input-field
make-radio-input-fields
make-submit-button make-submit-button
make-reset-button
make-image-button
input-field-value input-field-value
make-callback)) make-callback))

301
scheme/httpd/surflets/surflets.scm
View File

@ -201,114 +201,235 @@
(define (make-upper-input-field transformer HTML-tree) (define (make-upper-input-field transformer HTML-tree)
(list 'input-field (real-make-input-field #f transformer HTML-tree #t))) (list 'input-field (real-make-input-field #f transformer HTML-tree #t)))
;; PRED-LIST contains list of predicates that recognizes optional
;; leading parameters. FURTHER-ATTRIBUTES is the optional parameter
;; list as got by procedure call. PREFIX-OPTIONALS returns two values:
;; a list of the same length as PRED-LIST and a list containing the
;; left arguments that did not fit the predicates.
;;
;; With the help of PREFIX-OPTIONALS you can define a function
;; like `make-submit-button [string] [further-attributes]' this way:
;; (define (make-submit-button . args)
;; (receive (params rest-args)
;; (prefix-optionals (list string? XML-attribute?) args)
;; (if (pair? rest-args)
;; (error "too many arguments to make-submit-button))
;; (let ((value (first params))
;; (attributes (second params)))
;; ...))))
;;
(define (typed-optionals pred-list args)
(let loop ((results '())
(pred-list pred-list)
(args args))
(cond
((null? pred-list)
(values (reverse results) args))
((null? args)
(values (rev-append results (make-list (length pred-list) #f)) '()))
(((car pred-list) (car args))
(loop (cons (car args) results)
(cdr pred-list)
(cdr args)))
(else
(loop (cons #f results)
(cdr pred-list)
args)))))
(define-syntax optionals
(lambda (exp rename compare)
(let ((%receive (rename 'receive))
(%typed-optionals (rename 'typed-optionals))
(%list (rename 'list))
(%if (rename 'if))
(%pair? (rename 'pair?))
(%error (rename 'error))
(%let (rename 'let))
(%list-ref (rename 'list-ref))
(args (cadr exp))
(var-list (caddr exp))
(body (cadddr exp)))
`(,%receive (params rest-args)
(,%typed-optionals (,%list ,@(map cadr var-list)) ,args)
(,%if (pair? rest-args)
(,%error "optionals: too many arguments and/or argument type mismatch")
(,%let (,@(let loop ((counter 0)
(var-list var-list))
(if (null? var-list)
'()
(cons (cons (caar var-list) `((,%list-ref params ,counter)))
(loop (+ 1 counter)
(cdr var-list))))))
,body))))))
;; from uri.scm
(define (rev-append a b) ; (append (reverse a) b)
(let rev-app ((a a) (b b)) ; Should be defined in a list-proc
(if (pair? a) ; package, not here.
(rev-app (cdr a) (cons (car a) b))
b)))
(define (make-text-input-field . maybe-further-attributes) (define (make-text-input-field . maybe-further-attributes)
(let ((name (generate-input-field-name "text"))) (let ((name (generate-input-field-name "text")))
(make-input-field name (optionals maybe-further-attributes
identity ((attributes XML-attribute?))
`(input (@ (type "text") (make-input-field name
(name ,name) identity
,@maybe-further-attributes))))) `(input (@ (type "text")
(name ,name)
;; this will insert a list, but
;; XML->HTML doesn't care about it
,(and attributes (cdr attributes))
))))))
(define (make-number-input-field . maybe-further-attributes) (define (make-number-input-field . maybe-further-attributes)
(let ((name (generate-input-field-name "number"))) (let ((name (generate-input-field-name "number")))
(make-input-field (optionals maybe-further-attributes
name ((attributes XML-attribute?))
(lambda (string) (make-input-field
(or (string->number string) name
(error "wrong type"))) (lambda (string)
`(input (@ (type "text") (or (string->number string)
(name ,name) (error "wrong type")))
,@maybe-further-attributes))))) `(input (@ (type "text")
(name ,name)
,(and attributes (cdr attributes))))))))
(define (make-password-input-field . maybe-further-attributes) (define (make-password-input-field . maybe-further-attributes)
(let ((name (generate-input-field-name "password"))) (let ((name (generate-input-field-name "password")))
(make-input-field (optionals maybe-further-attributes
name ((attributes XML-attribute?))
identity (make-input-field
`(input (@ (type "password") name
(name ,name) identity
,@maybe-further-attributes))))) `(input (@ (type "password")
(name ,name)
,@(and attributes (cdr attributes))))))))
(define (make-textarea-input-field . maybe-further-attributes) (define (make-textarea-input-field . maybe-further-attributes)
(let ((name (generate-input-field-name "textarea")) (let ((name (generate-input-field-name "textarea")))
(default-text (if (and (pair? maybe-further-attributes) (optionals maybe-further-attributes
(string? (car maybe-further-attributes))) ((default-text string?)
(car maybe-further-attributes) (attributes XML-attribute?))
'()))) (make-input-field
(make-input-field name
name identity
identity `(textarea (@ (type "textarea")
`(textarea (@ (type "textarea") (name ,name)
(name ,name) ,(and attributes (cdr attributes)))
,@maybe-further-attributes) ,(and default-text))))))
,default-text))))
(define (make-select-input-field options . maybe-further-attributes) ;(make-select-input-fields '("this" "that" "those") '(@ ((id "sushi"))))
;(make-select-input-fields '("this" ("that" '(@ (selected))) "those"))
;; dropdown: (size 1)
;; multiple choice: (multiple)
;; preselected option: (selected)
;; changed return value: (value new-value)
;; returns a select input field with several options
(define (make-select-input-fields options . maybe-further-attributes)
(let ((name (generate-input-field-name "select"))) (let ((name (generate-input-field-name "select")))
(make-input-field (optionals maybe-further-attributes
name ((attributes XML-attribute?))
(lambda (select) (make-input-field
select) ;FIXME[extension] refer to list elements name
`(select (@ ((name ,name) (lambda (select)
,@maybe-further-attributes)) select) ;FIXME[extension] refer to list elements
#\newline `(select (@ ((name ,name)
,@(map (lambda (option) ,(and attributes (cdr attributes))))
(if (pair? option) ; with attributes? #\newline
`(option (@ ,@(cdr option)) ,(car option)) ,@(map (lambda (option)
`(option ,option))) (cond
options))))) ((string? option)
(list 'option option))
((list? option)
(cond
((null? (cdr option))
`(option ,option))
((XML-attribute? (cadr option)) ; with attributes?
`(option ,(cadr option) ,(car option)))
(else
(error "not an attribute" (cdr option)))))
(else
(error "not an option" option))))
options))))))
(define (make-checkbox-input-field . maybe-further-attributes) ;; returns a *list* of radio buttons
(let* ((name (generate-input-field-name "checkbox")) (define (make-radio-input-fields values . maybe-further-attributes)
(value (if (and (pair? maybe-further-attributes)
(string? (car maybe-further-attributes)))
(car maybe-further-attributes)
#f))
(further-attributes (if value
(cdr maybe-further-attributes)
maybe-further-attributes)))
(make-input-field
name
identity
`(input (@ ((type "checkbox")
(name ,name)
,(if value `(value ,value) '())
,@further-attributes))))))
;; in work
(define (make-radio-input-field values . maybe-further-attributes)
(let ((name (generate-input-field-name "radio"))) (let ((name (generate-input-field-name "radio")))
(make-input-field (optionals maybe-further-attributes
name ((attributes XML-attribute?))
(lambda (select) (map (lambda (value)
select) ;FIXME refer to list elements (let ((value-value (if (pair? value) (car value) value))
(map (lambda (value) (value-attributes (if (pair? value)
`((input (@ ((type "radio") (if (XML-attribute? (cadr value))
(name ,name) (cdadr value)
,@maybe-further-attributes (error "not an attribute" cadr value))
,(if (pair? value) ; with attributes? #f)))
(cdr value) (make-input-field
'())))) ;FIXME: add value field name
,(if (pair? value) ; with attributes? (lambda (select)
(car value) select) ;FIXME refer to list elements
value))) `(input (@ ((type "radio")
values)))) (name ,name)
(value ,value-value)
,(and value-attributes)
,(and attributes (cdr attributes))))))))
values))))
;; returns a checkbox input field
(define (make-checkbox-input-field . maybe-further-attributes)
(let* ((name (generate-input-field-name "checkbox")))
(optionals maybe-further-attributes
((value (lambda (a) (or (string? a)
(number? a)
(symbol? a))))
(attributes XML-attribute?))
(make-input-field
name
identity
`(input (@ ((type "checkbox")
(name ,name)
,(if value `(value ,value) '())
,(and attributes (cdr attributes)))))))))
(define (make-hidden-input-field value . maybe-further-attributes)
(let ((name (generate-input-field-name "hidden")))
(optionals maybe-further-attributes
((attributes XML-attribute?))
(make-input-field name
identity
`(input (@ (type "hidden")
(name ,name)
(value ,value)
,(and attributes (cdr attributes))))))))
(define (make-button type button-caption attributes)
`(input (@ (type ,type)
,(and button-caption `(value ,button-caption))
,(and attributes (cdr attributes)))))
(define (make-submit-button . maybe-further-attributes) (define (make-submit-button . maybe-further-attributes)
(if (and (pair? maybe-further-attributes) (optionals maybe-further-attributes
(string? (car maybe-further-attributes))) ((button-caption (lambda (a) (or (string? a)
`(input (@ (type "submit") (symbol? a))))
(value ,(car maybe-further-attributes)) (attributes XML-attribute?))
,@maybe-further-attributes)) (make-button "submit" button-caption attributes)))
`(input (@ (type "submit")
,@maybe-further-attributes)))) (define (make-reset-button . maybe-further-attributes)
(optionals maybe-further-attributes
((button-caption (lambda (a) (or (string? a)
(symbol? a))))
(attributes XML-attribute?))
(make-button "reset" button-caption attributes)))
(define (make-image-button image-source . maybe-further-attributes)
(optionals maybe-further-attributes
((attributes XML-attribute?))
(make-button "image" #f `(@ (src ,image-source)
,@(if attributes (cdr attributes) '())))))
(define (input-field-value input-field bindings) (define (input-field-value input-field bindings)
(let ((input-field (cadr input-field))) (let ((input-field (cadr input-field)))