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

;;; Copyright 2002, 2003 Andreas Bernauer


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; input-fields
;;; defines input-fields for surflets

(define *input-field-trigger* `*input-field*)

;; GET-BINDINGS?: Transformer will get all bindings of request, not
;; only the one concerning the input-field.
(define-record-type input-field :input-field
  (real-make-input-field name transformer html-tree get-bindings?)
  real-input-field?
  (name input-field-name)
  (transformer input-field-transformer)
  (attributes input-field-attributes)
  (html-tree input-field-html-tree)
  (get-bindings? input-field-get-bindings?))

(define-record-discloser :input-field
  (lambda (input-field)
    (list 'input-field
	  (input-field-name input-field))))

;; Have to do a trick to get around with SSAX: input-field is a list
;; whose first element is *input-field-trigger* and the last (next) one
;; is a 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 generate-input-field-name generate-unique-name)

(define identity (lambda (a) a))

;; See note at input-field? for reasons for the list.
(define (make-input-field name transformer html-tree)
  (list *input-field-trigger* 
	(real-make-input-field name transformer html-tree #f)))

(define (make-higher-input-field transformer html-tree)
  (list *input-field-trigger* 
	(real-make-input-field #f transformer html-tree #t)))

(define (make-text-input-field . maybe-further-attributes)
  (let ((name (generate-input-field-name "text")))
    (optionals maybe-further-attributes 
	((default-text string?)
	 (attributes sxml-attribute?))
      (make-input-field name
			identity
			`(input (@ (type "text")
				   (name ,name)
				   ,(and default-text `(value ,default-text))
				   ;; this will insert a list, but
				   ;; XML->HTML doesn't care about it
				   ,(and attributes (cdr attributes))
				   ))))))

(define make-number-input-field
  (let ((number-input-field-transformer
	 (lambda (string)
	   (or (string->number string)
	       (error "wrong type")))
	 ))
    (lambda maybe-further-attributes
      (let ((name (generate-input-field-name "number")))
	(optionals maybe-further-attributes
	    ((default (lambda (a) (or (number? a)
				      (string-or-symbol? a))))
	     (attributes sxml-attribute?))
	  (make-input-field
	   name
	   number-input-field-transformer
	   `(input (@ (type "text")
		      (name ,name)
		      ,(and default `(value ,default))
		      ,(and attributes (cdr attributes))))))))))

(define (make-password-input-field . maybe-further-attributes)
  (let ((name (generate-input-field-name "password")))
    (optionals maybe-further-attributes
	((attributes sxml-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")))
    (optionals maybe-further-attributes
	((default-text string?)
	 (attributes sxml-attribute?))
      (make-input-field 
       name
       identity
       `(textarea (@ (type "textarea")
		     (name ,name)
		     ,(and attributes (cdr attributes)))
		  ,(and default-text))))))

;(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-field 
  (let ((make-multiple-transformer
	 (lambda (name)
	   (lambda (bindings)
	     (map cdr
		  (filter (lambda (binding)
			    (equal? (car binding) name))
			  bindings))))))

    (lambda (options . maybe-further-attributes)
      (optionals maybe-further-attributes
	    ((multiple? boolean?)
	     (attributes sxml-attribute?))
	(let* ((name (generate-input-field-name "select"))
	       (sxml-options 
		(map (lambda (option)
		       (cond
			((string-or-symbol? option) 
			 (list 'option option))
			((list? option) 
			 (cond
			  ((null? (cdr option))
			   `(option ,option))
			  ((sxml-attribute? (cdr option)) ; w/attribs?
			   `(option ,(cdr option) ,(car option)))
			  (else
			   (error "not an attribute" (cdr option)))))
			(else
			 (error "not an option" option))))
		     options))
	       (sxml `(select (@ ((name ,name)
				 ,(if multiple? '(multiple) '())
				 ,(and attributes (cdr attributes))))
			     #\newline
			     ,sxml-options)))
	  (if multiple?
	      (make-higher-input-field (make-multiple-transformer name) sxml)
	      (make-input-field name identity sxml)))))))

;; 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 sxml-attribute?))
      (map (lambda (value)
	     (let ((value-value (if (pair? value) (car value) value))
		   (value-attributes (if (pair? value)
					 (if (sxml-attribute? (cdr value))
					     (cddr value)
					     (error "not an attribute" cdr value))
					 #f)))
	       (make-input-field
		name
		(lambda (select)
		  select)
		`(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
	((checked? boolean?)
	 (value (lambda (a) (or (string? a) 
				(number? a)
				(symbol? a))))
	 (attributes sxml-attribute?))
      (make-input-field
       name
       (lambda (value)
	 (or (string=? value "on")
	     value))
       `(input (@ ((type "checkbox")
		   (name ,name)
		   ,(if value `(value ,value) '())
		   ,(if checked? '(checked) '())
		   ,(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 sxml-attribute?))
      (make-input-field name
			identity
			`(input (@ (type "hidden")
				   (name ,name)
				   (value ,value)
				   ,(and attributes (cdr attributes))))))))

(define (make-button type name button-caption attributes)
  (make-input-field name
		    identity
		    `(input (@ (type ,type)
			       (name ,name)
			       ,(and button-caption `(value ,button-caption))
			       ,(and attributes (cdr attributes))))))

(define (string-or-symbol? a) 
  (or (string? a)
      (symbol? a)))

(define (make-submit-button . maybe-further-attributes)
  (optionals maybe-further-attributes
      ((button-caption string-or-symbol?)
       (attributes sxml-attribute?))
    (make-button "submit" (generate-input-field-name "submit")
		 button-caption attributes)))

(define (make-reset-button . maybe-further-attributes)
  (optionals maybe-further-attributes
      ((button-caption string-or-symbol?)
       (attributes sxml-attribute?))
    (make-button "reset" (generate-input-field-name "reset")  
		 button-caption attributes)))

(define (make-image-button image-source . maybe-further-attributes)
  (optionals maybe-further-attributes
      ((attributes sxml-attribute?))
    (make-button "image"  (generate-input-field-name "imgbtn")
		 #f `(@ (src ,image-source) 
			,@(if attributes (cdr attributes) '())))))

;; <input-field>: '(input-field . <real-input-field>)
;; <real-input-field>: #{Input-field "name"}
(define (raw-input-field-value input-field bindings)
  (let ((input-field (cadr input-field)))
    (cond
     ((input-field-get-bindings? input-field)
      ((input-field-transformer input-field) bindings))
     ((real-input-field-binding input-field bindings) =>
      (lambda (binding)
	((input-field-transformer 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)
       default)
     (raw-input-field-value input-field bindings))))

(define (real-input-field-binding input-field bindings)
  (assoc (input-field-name input-field) bindings))

(define (input-field-binding input-field bindings)
  (real-input-field-binding (cadr input-field) bindings))