sunet/scheme/httpd/surflets/input-fields.scm

172 lines
6.3 KiB
Scheme

;;; Copyright 2002, 2003 Andreas Bernauer
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; input-fields
;;; defines input-fields for surflets
;;; Globals
(define *input-field-trigger* `*input-field*)
(define generate-input-field-name generate-unique-name)
;;; Data structure for real-input-field
;; MULTI?: Transformer will get all bindings of request, not only the
;; one concerning the input-field.
(define-record-type real-input-field :real-input-field
(make-real-input-field name type transformer
attributes html-tree-maker
html-tree multi?)
real-input-field?
(name real-input-field-name)
(type real-input-field-type)
(transformer real-input-field-transformer)
(attributes real-input-field-attributes set-real-input-field-attributes!)
(html-tree-maker real-input-field-html-tree-maker)
(html-tree real-input-field-html-tree set-real-input-field-html-tree!)
(multi? real-input-field-multi?))
(define-record-discloser :real-input-field
(lambda (input-field)
(list 'real-input-field
(real-input-field-type input-field)
(real-input-field-name input-field))))
(define-syntax with-real-input-field
(lambda (expr rename compare)
(let ((%if (rename 'if))
(%let (rename 'let))
(%cadr (rename 'cadr))
(%input-field? (rename 'input-field?))
(%error (rename 'error))
(input-field (cadr expr))
(body (cddr expr)))
`(,%if (,%input-field? ,input-field)
(,%let ((real-input-field (,%cadr ,input-field)))
,@body)
(,%error "Invalid argument. Function wants an input-field."
,input-field)))))
;;; Fake input-field record. This is necessary, as the trigger in SXML
;;; may only be symbols, not arbitrary values. Thus, our input-fields
;;; must be preceeded by a trigger symbol to get recognized by the
;;; SXML transforming routines like sxml->html.
;; Constructors: make-input-field, make-multi-input-field
;; Predicates: input-field?
;; Selectors: input-field-name, input-field-type,
;; input-field-transformer, input-field-attributes,
;; input-field-html-tree-maker, input-field-html-tree,
;; input-field-multi?
;; Mutators: set-input-field-attributes!, touch-input-field!
;;; Constructors for input-field / multi-input-field
(define (make-input-field name type transformer attributes
html-tree-maker)
(make-sxml-input-field
(make-real-input-field name type transformer
attributes html-tree-maker #f #f)))
(define (make-multi-input-field name type transformer attributes
html-tree-maker)
(make-sxml-input-field
(make-real-input-field name type transformer
attributes html-tree-maker #f #t)))
(define (make-sxml-input-field real-input-field)
(list *input-field-trigger* real-input-field))
(define (input-field? input-field)
(and (pair? input-field)
(eq? *input-field-trigger* (car input-field))
(real-input-field? (cadr input-field))))
(define (make-input-field-selector selector)
(lambda (input-field)
(with-real-input-field input-field
(selector real-input-field))))
(define (make-input-field-setter setter . maybe-reset?)
(let ((reset? (:optional maybe-reset? #f)))
(lambda (input-field value)
(with-real-input-field input-field
(if reset?
(set-real-input-field-html-tree! real-input-field #f))
(setter real-input-field value)))))
(define input-field-name (make-input-field-selector real-input-field-name))
(define input-field-type (make-input-field-selector real-input-field-type))
(define input-field-transformer
(make-input-field-selector real-input-field-transformer))
(define input-field-attributes
(make-input-field-selector real-input-field-attributes))
(define input-field-html-tree-maker
(make-input-field-selector real-input-field-html-tree-maker))
(define (input-field-html-tree input-field)
(with-real-input-field input-field
(cond
((real-input-field-html-tree real-input-field)
=> identity)
(else
(let ((html-tree ((real-input-field-html-tree-maker real-input-field)
input-field)))
(set-real-input-field-html-tree! real-input-field html-tree)
html-tree)))))
(define input-field-multi?
(make-input-field-selector real-input-field-multi?))
(define set-input-field-attributes! (make-input-field-setter set-real-input-field-attributes! #t))
;; not exported:
(define set-input-field-html-tree! (make-input-field-setter set-real-input-field-html-tree!))
;; A touched input-field's html-tree will be recalculated if
;; neccessary.
(define (touch-input-field! input-field)
(set-input-field-html-tree! input-field #f))
;; <input-field>: '(input-field . <real-input-field>)
;; <real-input-field>: #{Real-input-field "name"}
(define (raw-input-field-value input-field bindings)
(let ((real-input-field (cadr input-field)))
(cond
((real-input-field-multi? real-input-field)
((real-input-field-transformer real-input-field) input-field bindings))
((real-input-field-binding real-input-field bindings) =>
(lambda (binding)
((real-input-field-transformer real-input-field) (cdr binding))))
(else
(error "no such input-field" input-field bindings)))))
;; Trys to get a value for INPUT-FIELD in BINDINGS. If this fails
;; (i.e. RAW-INPUT-FIELD-VALUE returns an error), the default-value is
;; returned. The default-value defaults to #f. NOTE: If you do this
;; with input-fields whose valid values may be the same as the default
;; value, you cannot determine by the result if there was such a value
;; or not. Keep in mind, that RAW-INPUT-FIELD-VALUE returns also an
;; error, if there was not such an input field. This makes
;; INPUT-FIELD-VALUE working with checkbox input fields because they
;; miss if they are not checked.
(define (input-field-value input-field bindings . maybe-default)
(let ((default (:optional maybe-default #f)))
(with-fatal-error-handler
(lambda (condition more)
; (format #t "hit error condition: ~s~%" condition)
default)
(raw-input-field-value input-field bindings))))
(define (real-input-field-binding input-field bindings)
(assoc (real-input-field-name input-field) bindings))
;; Returns the binding of the input-field in bindings by the
;; input-field's name. If your input-field will have another name in
;; the bindings than it was created with, use a multi-input-field.
(define (input-field-binding input-field bindings)
(real-input-field-binding (cadr input-field) bindings))
;;EOF