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))

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

@ -201,16 +201,93 @@
(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")))
(optionals maybe-further-attributes
((attributes XML-attribute?))
(make-input-field name (make-input-field name
identity identity
`(input (@ (type "text") `(input (@ (type "text")
(name ,name) (name ,name)
,@maybe-further-attributes))))) ;; 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")))
(optionals maybe-further-attributes
((attributes XML-attribute?))
(make-input-field (make-input-field
name name
(lambda (string) (lambda (string)
@ -218,97 +295,141 @@
(error "wrong type"))) (error "wrong type")))
`(input (@ (type "text") `(input (@ (type "text")
(name ,name) (name ,name)
,@maybe-further-attributes))))) ,(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")))
(optionals maybe-further-attributes
((attributes XML-attribute?))
(make-input-field (make-input-field
name name
identity identity
`(input (@ (type "password") `(input (@ (type "password")
(name ,name) (name ,name)
,@maybe-further-attributes))))) ,@(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)
,@maybe-further-attributes) ,(and attributes (cdr attributes)))
,default-text)))) ,(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"))) (let ((name (generate-input-field-name "select")))
(optionals maybe-further-attributes
((attributes XML-attribute?))
(make-input-field (make-input-field
name name
(lambda (select) (lambda (select)
select) ;FIXME[extension] refer to list elements select) ;FIXME[extension] refer to list elements
`(select (@ ((name ,name) `(select (@ ((name ,name)
,@maybe-further-attributes)) ,(and attributes (cdr attributes))))
#\newline #\newline
,@(map (lambda (option) ,@(map (lambda (option)
(if (pair? option) ; with attributes? (cond
`(option (@ ,@(cdr option)) ,(car option)) ((string? option)
`(option ,option))) (list 'option option))
options))))) ((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))))))
;; returns a *list* of radio buttons
(define (make-radio-input-fields values . maybe-further-attributes)
(let ((name (generate-input-field-name "radio")))
(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) (define (make-checkbox-input-field . maybe-further-attributes)
(let* ((name (generate-input-field-name "checkbox")) (let* ((name (generate-input-field-name "checkbox")))
(value (if (and (pair? maybe-further-attributes) (optionals maybe-further-attributes
(string? (car maybe-further-attributes))) ((value (lambda (a) (or (string? a)
(car maybe-further-attributes) (number? a)
#f)) (symbol? a))))
(further-attributes (if value (attributes XML-attribute?))
(cdr maybe-further-attributes)
maybe-further-attributes)))
(make-input-field (make-input-field
name name
identity identity
`(input (@ ((type "checkbox") `(input (@ ((type "checkbox")
(name ,name) (name ,name)
,(if value `(value ,value) '()) ,(if value `(value ,value) '())
,@further-attributes)))))) ,(and attributes (cdr attributes)))))))))
;; in work (define (make-hidden-input-field value . maybe-further-attributes)
(define (make-radio-input-field values . maybe-further-attributes) (let ((name (generate-input-field-name "hidden")))
(let ((name (generate-input-field-name "radio"))) (optionals maybe-further-attributes
(make-input-field ((attributes XML-attribute?))
name (make-input-field name
(lambda (select) identity
select) ;FIXME refer to list elements `(input (@ (type "hidden")
(map (lambda (value)
`((input (@ ((type "radio")
(name ,name) (name ,name)
,@maybe-further-attributes (value ,value)
,(if (pair? value) ; with attributes? ,(and attributes (cdr attributes))))))))
(cdr value)
'())))) ;FIXME: add value field
,(if (pair? value) ; with attributes?
(car value)
value)))
values))))
(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)))