+ 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

View File

@ -74,9 +74,16 @@
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
((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
httpd-request
uri ;URI-PATH-LIST->PATH
@ -96,6 +103,7 @@
defrec-package ;DEFINE-RECORD
threads ;SLEEP
thread-fluids ;FORK-THREAD
sxml-to-html ;SXML->HTML
scsh ;regexp et al.
scheme
)
@ -116,13 +124,17 @@
make-input-field
make-upper-input-field
make-text-input-field
make-hidden-input-field
make-password-input-field
make-number-input-field
make-textarea-input-field
make-select-input-field
make-select-input-fields
make-checkbox-input-field
make-radio-input-fields
make-submit-button
make-reset-button
make-image-button
input-field-value
make-callback))

View File

@ -201,114 +201,235 @@
(define (make-upper-input-field transformer HTML-tree)
(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)
(let ((name (generate-input-field-name "text")))
(make-input-field name
identity
`(input (@ (type "text")
(name ,name)
,@maybe-further-attributes)))))
(optionals maybe-further-attributes
((attributes XML-attribute?))
(make-input-field name
identity
`(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)
(let ((name (generate-input-field-name "number")))
(make-input-field
name
(lambda (string)
(or (string->number string)
(error "wrong type")))
`(input (@ (type "text")
(name ,name)
,@maybe-further-attributes)))))
(optionals maybe-further-attributes
((attributes XML-attribute?))
(make-input-field
name
(lambda (string)
(or (string->number string)
(error "wrong type")))
`(input (@ (type "text")
(name ,name)
,(and attributes (cdr attributes))))))))
(define (make-password-input-field . maybe-further-attributes)
(let ((name (generate-input-field-name "password")))
(make-input-field
name
identity
`(input (@ (type "password")
(name ,name)
,@maybe-further-attributes)))))
(optionals maybe-further-attributes
((attributes XML-attribute?))
(make-input-field
name
identity
`(input (@ (type "password")
(name ,name)
,@(and attributes (cdr attributes))))))))
(define (make-textarea-input-field . maybe-further-attributes)
(let ((name (generate-input-field-name "textarea"))
(default-text (if (and (pair? maybe-further-attributes)
(string? (car maybe-further-attributes)))
(car maybe-further-attributes)
'())))
(make-input-field
name
identity
`(textarea (@ (type "textarea")
(name ,name)
,@maybe-further-attributes)
,default-text))))
(let ((name (generate-input-field-name "textarea")))
(optionals maybe-further-attributes
((default-text string?)
(attributes XML-attribute?))
(make-input-field
name
identity
`(textarea (@ (type "textarea")
(name ,name)
,(and attributes (cdr attributes)))
,(and 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")))
(make-input-field
name
(lambda (select)
select) ;FIXME[extension] refer to list elements
`(select (@ ((name ,name)
,@maybe-further-attributes))
#\newline
,@(map (lambda (option)
(if (pair? option) ; with attributes?
`(option (@ ,@(cdr option)) ,(car option))
`(option ,option)))
options)))))
(optionals maybe-further-attributes
((attributes XML-attribute?))
(make-input-field
name
(lambda (select)
select) ;FIXME[extension] refer to list elements
`(select (@ ((name ,name)
,(and attributes (cdr attributes))))
#\newline
,@(map (lambda (option)
(cond
((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)
(let* ((name (generate-input-field-name "checkbox"))
(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)
;; returns a *list* of radio buttons
(define (make-radio-input-fields values . maybe-further-attributes)
(let ((name (generate-input-field-name "radio")))
(make-input-field
name
(lambda (select)
select) ;FIXME refer to list elements
(map (lambda (value)
`((input (@ ((type "radio")
(name ,name)
,@maybe-further-attributes
,(if (pair? value) ; with attributes?
(cdr value)
'())))) ;FIXME: add value field
,(if (pair? value) ; with attributes?
(car value)
value)))
values))))
(optionals maybe-further-attributes
((attributes XML-attribute?))
(map (lambda (value)
(let ((value-value (if (pair? value) (car value) value))
(value-attributes (if (pair? value)
(if (XML-attribute? (cadr value))
(cdadr value)
(error "not an attribute" cadr value))
#f)))
(make-input-field
name
(lambda (select)
select) ;FIXME refer to list elements
`(input (@ ((type "radio")
(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)
(if (and (pair? maybe-further-attributes)
(string? (car maybe-further-attributes)))
`(input (@ (type "submit")
(value ,(car maybe-further-attributes))
,@maybe-further-attributes))
`(input (@ (type "submit")
,@maybe-further-attributes))))
(optionals maybe-further-attributes
((button-caption (lambda (a) (or (string? a)
(symbol? a))))
(attributes XML-attribute?))
(make-button "submit" button-caption 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)
(let ((input-field (cadr input-field)))