172 lines
6.3 KiB
Scheme
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 |