Chapter 5. The IMHO Package

Table of Contents
5.1. Classes
5.2. Important Variables
5.3. Functions

5.1. Classes

This section describes the basic classes that must be manipulated in order to build working IMHO programs.

5.1.1. The application Class

The application encapsulates information common to all sessions of an application, such as the path to templates for rendering its html elements, and the application's public base URL. In general, you don't need to directly subclass application (using defclass), you can use the 'defapplication' macro.

defmacro defapplication (name &key initial-element initial-method  session-class base-url template-root script-root)

5.1.2. The http-session Class

This class provides the relation of client requests to server-side state.

(defclass http-session ()
  ((session-id
    :accessor session-id
    :initarg :id)
   (session-html-elements
    :accessor session-html-elements
    :initform (make-hash-table :test 'equal))
   (session-instances
    :accessor session-instances
    :initform (make-hash-table :test 'equal))
   (session-application
    :accessor session-application
    :initarg :application
    :initform nil)
   (active-response
    :initform nil)
   (last-url
    :accessor last-url
    :initarg :last-url
    :initform nil
    :documentation
    "The last URL visited by this session's client.  This is really
here to support a 'go back' link from a help system page. I wonder if
this is the right way to do it.")
   (help-target
    :accessor help-target
    :initarg :help-target
    :initform "help-main")
   (timeout
    :accessor session-timeout
    :initarg :session-timeout
    :initform 300
    :documentation
    "Idle Timeout in seconds")
   (timestamp
    :accessor session-timestamp
    :initarg :session-timestamp
    :initform (get-universal-time)
    :documentation
    "Used for determining if session has timed-out"))
  (:documentation
   "A session encapsulates all required information about a set of
interactions with a client browser.  Subclasses should store
authentication data and other objects that persist across requests."))

5.1.3. HTML elements

;; ------------------------------------------------------------
;; framework class: html-element
;;
;; This is the root of the html-element inheritance graph.
;;
;; Some classes to derive their rendering behavior from HTML templates
;; residing in the filesystem, and others from overriding
;; 'render-html'.
(defclass html-element ()
  ((element-external-name
    :reader element-external-name
    :initarg :element-external-name
    :initform (symbol-name (gensym "C"))
    :documentation
    "The externalized name of this html-element, for use in URLs or
interhtml-element references in HTML or client-side code. Guaranteed
unique.")
   (element-internal-name
    :accessor element-internal-name
    :initarg :element-internal-name
    :documentation
    "The name used by this html-element's parent to refer to it.")
   (value
    :initarg :value
    :initform nil
    :documentation
    "application 'value' of this html-element, returned by IMHO public
object protocol")
   (session
    :initarg :session
    :initform nil)
   (parent
    :accessor element-parent
    :initarg :parent
    :initform nil)
   (children
    :initform (make-hash-table)
    :documentation
    "A hashtable of children that are dynamically rendered by this
html-element; keys are the internal names of these children."))
  (:documentation
   "Base display html-element for applications")
  )

;;
;; Hashtable of children
;;

(defmethod element-children ((element html-element))
  (slot-value element 'children))

;;
;; Children which should have values taken
;;

(defmethod element-active-children ((element html-element))
  (let (children)
    (maphash (lambda (k v)
	       (declare (ignore k))
	       (setq children (cons v children)))
	     (element-children element))
    children))

(defgeneric html-element-all-children (t)
  (:documentation
   "Given a child, returns a list of all children composing that
child."))

(defmethod html-element-all-children ((element html-element))
  (let ((children (list element)))
    (maphash (lambda (k v)
	       (declare (ignore k))
	       (setq children (append (html-element-all-children v) children)))
	     (element-children element))
    children))
  
;; ------------------------------------------------------------
;; clos-method: initialize-instance
;;
;; default initializer for html-elements.

(defmethod initialize-instance ((element html-element) &rest initargs)
;  (declare (ignore initargs))
  (call-next-method)
  (if (and (slot-boundp element 'ext-name)
	   (not (slot-boundp element 'int-name)))
      (setf (slot-value element 'int-name)
	    (slot-value element 'ext-name))))
      
;      (let ((name (symbol-name (gensym "C")))) ;; (symbol-name (type-of element))))))
;;;  (if (and (not (slot-boundp element 'session))
;	   (element-parent element))
;      (setf (slot-value element 'session)
;	    (slot-value (element-parent element) 'session))))

;; ------------------------------------------------------------
;; framework-method: render-html
;;
;; This is the default renderer for html-elements. If this method has not
;; been specialized to a subclass, we look around for an html template
;; for this html-element.

(defmethod render-html ((element html-element) stream)
  (let ((template (html-template *active-application* (type-of element))))
    (dolist (item (html-template-content template))
      (ecase (car item)
	(:string
	 (format stream (cadr item)))
	(:child
	 (let ((child (child-element element (cadr item))))
	   (if child
	       (render-html child stream)
	       (format stream "[missing child: '~a']" (cadr item)))))))))

(defmethod render-html :around ((element html-element) stream)
  (with-slots (ext-name int-name)
    element
    (let ((sname (symbol-name (type-of element))))
      (format stream "~%~%"
	      sname int-name ext-name)
      ;; keep track of the classes of components on this page.
      (setf (gethash (type-of element) *active-components*) t)
      (call-next-method)
      (format stream "~%~%"
	      sname int-name ext-name))))

;; ------------------------------------------------------------
;; accessors for 'html-element value'

;; FIX: differentiate between display value and internal value? - JLB

(defgeneric element-value (t)
  (:documentation
   "This function provides a means of communicating
application-meaningful values in and out of HTML and client side
representations.  Values come from and go to the client via the pair
of functions 'get-values-from-response' and 'render-html', and are got
and set by server code via this function and its corresponding setf.")
  )
  
(defmethod element-value ((element html-element))
  (slot-value element 'value))

(defmethod set-element-value ((html-element html-element) value)
  (setf (slot-value html-element 'value) value))

(defsetf element-value set-element-value)

;; ------------------------------------------------------------
;; Build an URL for a html-element.

(defmethod element-url ((element html-element) &key (method nil) (arg nil))
  (let ((path (concatenate 'string *active-url* (slot-value element 'ext-name) "/")))
    (if method
	(progn
	  (setq path (concatenate 'string path method))
	  (if arg
	      ;; FIXME: do inverse url argument encoding
	      (setq path (concatenate 'string path "?" arg)))))
    path))

(defmethod element-url (no-parent &key (method nil) (arg nil))
  (let ((path (concatenate 'string *active-url* "parentless" "/")))
    (if method
	(progn
	  (setq path (concatenate 'string path method))
	  (if arg
	      ;; FIXME: do inverse url argument encoding
	      (setq path (concatenate 'string path "?" arg)))))
    path))

;; ------------------------------------------------------------
;; get/set a child element

(defmethod child-element ((element html-element) int-name)
  (or (gethash int-name (element-children element))
      (make-instance 'static-string :value (format nil "[Missing Child: ~a]" int-name))))

(defmethod set-child-element ((element html-element) int-name child)
  (setf (element-parent child) element
	(slot-value child 'int-name) int-name
	(gethash int-name (element-children element)) child)
  child)

(defsetf child-element (element int-name) (child)
  `(set-child-element ,element ,int-name ,child))

;; ------------------------------------------------------------
;; Set a bunch of child elements to instances.
;; Call like this;
;;
;;    (instantiate-children
;;         parent
;;        '((child-name make-instance-arg1 make-instance-arg2 ...) ...))

(defun instantiate-children (parent param-list)
  (flet ((instantiate
          (lst)
          (let ((child-name (car lst))
                (make-instance-args (cdr lst)))
            (setf (child-element parent child-name)
                  (apply #'make-instance make-instance-args)))))
    (mapc #'instantiate param-list)))

(defmacro child-value (ele child)
  `(element-value (child-element ,ele ,child)))

;; ------------------------------------------------------------
;; Bind multiple child values from a html-element instance

(defmacro with-children (values element &body body)
  (let ((comp (gensym)))
    `(let ((,comp ,element))
       (declare (ignorable ,comp))
       ,@(let ((element element))
	   (and (symbolp element)
                `((declare (variable-rebinding ,comp ,element)))))
       ,comp
       (symbol-macrolet ,(mapcar #'(lambda (value-entry)
				     (let ((value-name 
					    (if (symbolp value-entry)
						value-entry
						(car value-entry)))
					   (child-name
					    (if (symbolp value-entry)
						value-entry
						(cadr value-entry))))
				       `(,value-name
					 (element-value (child-element ,comp ',child-name)))))
				 values)
			,@body))))

(defmethod make-html-element ((session http-session) element-class &rest initargs)
  (let* ((instance-args (append (list element-class :session session) initargs))
	 (element (apply #'make-instance instance-args)))
    (setf (session-element session) element)
    element))

;; ------------------------------------------------------------
;; framework class: html-form
;;
;; A form html-element

(defclass html-form (html-element)
  ((method
    :accessor method
    :initarg :method)
   (target
    :accessor form-target
    :initarg :target)
   (form-children
    :accessor form-children
    :initform nil
    :initarg :form-children))
  (:documentation
   "Provides a mechanism for managing interaction with an HTML
form. Children of an instance of html-form will automatically
have their values set and extracted.")
  )

;; ------------------------------------------------------------
;; clos-method: initialize-instance
;;
;; Establish the default target for this form

(defmethod initialize-instance ((form html-form) &rest initargs)
  (declare (ignore initargs))
  (call-next-method)
  (if (not (slot-boundp form 'target))
      (setf (slot-value form 'target)
	    (or (element-parent form) form)))
  #+broken
  ;; todo: this was causing too many problems, but in the abstract
  ;; might still be a good idea.
  (if (not (slot-boundp form 'method))
      (error "No method specified for ~A~%" form))
  )

(defmethod take-values-from-request ((form html-form) request)
  (dolist (target (form-children form))
    (let ((value (cadr (assoc (car target)
			      (request-http-client-content request)
			      :test #'equal))))
      (funcall (cadr target) value)))
  t)

(defmethod render-html :around ((html-element html-form) stream)
  (with-slots (ext-name target method)
    html-element
    (let ((action (element-url (or target html-element) :method method)))
      (with-tag (:stream stream :tag "FORM" :attr `(("METHOD" . "POST")
						    ("NAME" . ,ext-name)
						    ("ACTION" . ,action)))
	(call-next-method)))))

;; ------------------------------------------------------------
;; framework class: html-form-element

(defclass html-form-element (html-element)
  ((parent-name
    :accessor external-form-name
    :initform nil))
  )

(defmethod set-child-element ((form html-form)
			      int-name
			      (child html-form-element))
  (call-next-method)
;;  (format t ";; AC: ~s -> ~s~%" form child)
  (setf (external-form-name child) (element-external-name form))
  (setf (form-children form)
	(cons (list (element-external-name child)
		    (lambda (value)
		      (setf (element-value child) value)))
	      (form-children form))))

;; ------------------------------------------------------------
;; framework class: html-form-element

(defclass labelled ()
  ((label
    :accessor field-label
    :initarg :label
    :initform nil))
  )

(defmethod render-html :around ((labelled labelled) stream)
  (with-slots (label)
    labelled
    (if label
	(with-tag (:stream stream :tag "TABLE" :attr '(("BORDER" . "0")
						       ("CELLSPACING" . "0")
						       ("CELLPADDING" . "0")))
	  (with-tag (:stream stream :tag "TR")
	    (with-tag (:stream stream :tag "TD" :attr '(("VALIGN" . "MIDDLE")))
	      (write-string label stream)
	      (write-string " " stream))
	    (with-tag (:stream stream :tag "TD" :attr '(("VALIGN" . "BOTTOM")))
	      (call-next-method))))
	(call-next-method))))

;; ------------------------------------------------------------
;; html-element: popup-list

(defclass popup-list (html-form-element labelled)
  ((popup-values
    :accessor popup-values
    :initform nil
    :initarg :list-values
    :documentation
    "A function that returns an alist of strings and values for the html-element."))
  )

(defmethod render-html ((element popup-list) stream)
  (with-slots (ext-name)
    element
    (with-tag (:stream stream :tag "SELECT" :attr `(("SIZE" . "1")
						    ("NAME" . ,ext-name)))
      (dolist (x (funcall (popup-values element)))
	(with-tag (:stream stream :tag "OPTION" :attr `(("VALUE" . ,(car x))))
	  (write-string (cdr x) stream))))))
   
;; ------------------------------------------------------------
;; html-element: submit-button

(defclass submit-button (html-form-element)
  ((display-string
    :accessor display-string
    :initform "Submit"
    :initarg :value))
  )

(defmethod render-html ((button submit-button) stream)
  (with-slots (ext-name display-string)
    button
    (with-tag (:stream stream :tag "INPUT" :noclose t
		       :attr `(("TYPE" . "SUBMIT")
			       ("NAME" . ,ext-name)
			       ("VALUE" . ,display-string))))))

;; ------------------------------------------------------------
;; html-element: text-field

(defclass text-field (html-form-element labelled)
  ((visible
    :initform t)
   (columns
    :initarg :cols
    :initform 30))
  )

(defmethod element-value ((field text-field))
  (or (call-next-method) ""))

(defmethod render-html ((field text-field) stream)
  (with-slots (ext-name visible columns)
    field
    (let* ((value (element-value field))
           (string (typecase value
                     (function	(funcall value))
                     (t		""))))
      (with-tag (:stream stream
                         :tag "INPUT"
                         :noclose t
                         :attr `(("TYPE" . ,(if visible "TEXT" "PASSWORD"))
                                 ("SIZE" . ,(format nil "~d" columns))
                                 ("NAME" . ,ext-name)
                                 ("VALUE" . ,string)))))))
  
;; ------------------------------------------------------------
;; html-element: text-area

(defclass text-area (html-form-element labelled)
  ((wrap-type
    :initarg :wrap
    :initform :hard)
   (columns
    :initarg :cols
    :initform 40)
   (rows
    :initarg :rows
    :initform 5)
   )
  )

(defmethod text-area-wrap-attribute ((field text-area))
  (with-slots (wrap-type)
    field
    (case wrap-type
      (:hard
       "HARD")
      (t
       "HARD"))))

(defmethod element-value ((field text-area))
  (or (call-next-method) ""))

(defmethod render-html ((field text-area) stream)
  (with-slots (ext-name rows columns)
    field
    (let* ((value (element-value field))
           (string (typecase value
                     (function	(funcall value))
                     (t		""))))
      (with-tag (:stream stream
                         :tag "TEXTAREA"
                         :attr `(("TYPE" . "TEXTAREA")
                                 ("WRAP" . ,(text-area-wrap-attribute field))
                                 ("ROWS" . ,(format nil "~d" rows))
                                 ("COLS" . ,(format nil "~d" columns))
                                 ("NAME" . ,ext-name)))
        (write-string string stream)))))
  
;; ------------------------------------------------------------
;; html-element: fancy-text-field

(defclass fancy-text-field (html-form-element labelled)
  ((visible
    :initform t))
  )

(defmethod element-value ((field fancy-text-field))
  (or (call-next-method) ""))

(defmethod render-html ((field fancy-text-field) stream)
  (with-slots (ext-name)
    field
    (with-tag (:stream stream :tag "INPUT" :noclose t
		       :attr `(("TYPE" . "HIDDEN")
			       ("NAME" . ,ext-name))))
    (with-tag (:stream stream :tag "APPLET"
		       :attr `(("CODE" . "ValidTextInput.class")
			       ("CODEBASE" . "http://cafe.onshore.com/lang/java/test")
			       ("WIDTH" . "90") ("HEIGHT" . "35")
			       ("NAME" . ,(concatenate 'string ext-name "A"))
			       ("MAYSCRIPT")))
      (param-tag stream "form-target" (external-form-name field))
      (param-tag stream "hidden-target" ext-name))))
  
;; ------------------------------------------------------------
;; html-element: password-field

(defclass password-field (text-field)
  )

(defmethod initialize-instance ((field password-field) &rest initargs)
  (declare (ignore initargs))
  (call-next-method)
  (setf (slot-value field 'visible) nil))
   
;; ------------------------------------------------------------
;; html-element: checkbox

(defclass checkbox (html-form-element labelled)
  )

(defmethod set-element-value ((element checkbox) value)
  (format t ";; checkbox value : ~S~%" value)
  (setf (slot-value element 'value)
	(equal value "on")))

(defmethod render-html ((element checkbox) stream)
  (with-slots (ext-name)
    element
    (with-tag (:stream stream
		       :tag "INPUT"
		       :attr `(("TYPE" . "CHECKBOX")
			       ("NAME" . ,ext-name))))))

;; ------------------------------------------------------------
;; html-element: radio-button

(defclass radio-button (html-form-element labelled)
  ((group
    :initarg :group
    :initform "RADIO"
    :documentation
    "Group to which a radio button belongs")
   (checked
    :initarg :checked
    :initform nil
    :documentation
    "Whether this button is initially checked in its group"))
  )


;; A radio button returns t if it's on, nil otherwise
(defmethod element-value ((button radio-button))
  (let* ((gname          (slot-value button 'group))
         (self           (slot-value button 'ext-name))
         (received-value (cadr
                          (assoc
                           gname (request-http-client-content *active-request*)
                           :test #'string-equal))))
    (string-equal received-value self)))

(defmethod render-html ((element radio-button) stream)
  (with-slots (ext-name group checked)
    element
    (with-tag (:stream stream
		       :tag "INPUT"
		       :noclose t
		       :attr `(("TYPE" . "RADIO")
			       ("NAME" . ,group)
			       ,@(if checked '(("CHECKED")))
			       ("VALUE" . ,ext-name))))))

;; ------------------------------------------------------------
;; html-element: reset-button

(defclass reset-button (html-element)
  )

(defmethod render-html ((reset-button reset-button) stream)
  (format stream "<INPUT TYPE=RESET>"))
   
;; ------------------------------------------------------------
;; html-element: file-chooser

(defclass file-chooser (html-element)
  )

(defmethod render-html ((file-chooser file-chooser) stream)
  (format stream "<INPUT TYPE=FILE>"))
   
;; ------------------------------------------------------------
;; html-element: image-input

(defclass image-input (html-element)
  )

(defmethod render-html ((image-input image-input) stream)
  (format stream "<INPUT TYPE=IMAGE>"))
   
;; ------------------------------------------------------------
;; html-element: button

(defclass button (html-element)
  ()
  (:documentation
   "An HTML form button.\\footnote{FIX - This one isn't implemented
yet.}")
  )

(defmethod render-html ((button button) stream)
  (format stream "<INPUT TYPE=BUTTON>"))
   


;; -*- Syntax: Ansi-Common-Lisp; Base: 10; Mode: lisp; Package: imho -*-
;; $Id: tutorial.sgml,v 1.10 2002/04/29 20:36:55 craig Exp $

(in-package :imho)

;;
;; Basic non-form elements
;;

;; ------------------------------------------------------------
;; html-element: html-page

(defclass html-page (html-element)
  )

(defmethod render-html :around ((page html-page) stream)
  (with-tag (:stream stream :tag "HTML")
    (with-tag (:stream stream :tag "HEAD")
      (with-tag (:stream stream :tag "TITLE")
	(format stream "PAGE")))
    (with-tag (:stream stream :tag "BODY"
		       :attr '(("BGCOLOR" . "#ffffff")))
      (call-next-method))))


;; ------------------------------------------------------------
;; html-element: static-string

(defclass static-string (html-element)
  )

(defmethod render-html ((element static-string) stream)
  (let* ((value (element-value element))
	 (string (typecase value
		   (string	(if (equal value "") "&nbsp;" value))
		   (function	(funcall value))
		   (t		"&nbsp;"))))
    (write-string string stream)))


;; ------------------------------------------------------------
;; html-element: hyperlink
;;
;; FIX: support hyperlinked images

(defclass hyperlink (html-element)
  ((method
    :accessor method
    :initarg :method
    :initform nil)
   (reference
    :accessor reference
    :initarg :reference
    :initform nil))
  )

;; ------------------------------------------------------------
;; framework-method: element-value
;;
;; Allow the 'value' slot of a hyperlink to be a zero-arity function
;; that returns the content for the link.

(defmethod component-value ((hyperlink hyperlink))
  (with-slots (value)
    hyperlink
    (etypecase value
      (function (funcall value))
      (string value))))

;; TODO: "precompile" the output text for the url (don't call format
;; too often inside of 'render'

(defmethod render-html ((hyperlink hyperlink) stream)
  (with-slots (method reference)
    hyperlink
    (let (href)
      (cond (method
	     (setq href (element-url (element-parent hyperlink) :method method)))
            (reference
             (setq href (element-url (element-parent hyperlink) :method reference)))
;;	     (setq href reference))
	    (t
	     (error "hyperlink without reference")))
      (with-tag (:stream stream :tag "A" :attr `(("HREF" . ,href)))
	(format stream "~A" (element-value hyperlink))))))


;; ------------------------------------------------------------
;; html-element: table-interior

(defclass table-interior (html-element)
  ((elements
    :accessor elements
    :initarg :elements
    :initform nil
    :documentation
    ;; todo -- settle this question:
    "List of cells (strings, hyperlinks, or other html-elements?).")
   (rows
    :accessor rows
    :initarg :rows
    :initform nil
    :documentation
    "The number of rows in this table.")
   (columns
    :accessor columns
    :initarg :columns
    :initform nil
    :documentation
    "The number of columns in this table.")
   (align
    :accessor align
    :initarg :align
    :initform "center"
    :documentation
    "Horizontal alignment of the cell contents in this table.")
   (valign
    :accessor valign
    :initarg :valign
    :initform ""
    :documentation
    "Vertical alignment of the cell contents in this table.")
   (colspan
    :accessor colspan
    :initarg :colspan
    :initform "1"
    :documentation
    "Number of columns each row occupies."))
  (:documentation
   "The inside of an html table, that is, the rows and columns.
Does not include the table declaration itself."))


(defmethod render-html ((guts table-interior) stream)
  (let ((elements (elements guts)))
    (do ((row 0 (incf row)))
        ((or (null elements) (and (rows guts) (= row (rows guts)))))
      (with-tag (:stream stream :tag "TR")
        (do ((col 0 (incf col)))
            ((or (null elements) (and (columns guts) (= col (columns guts)))))
          (with-tag (:stream stream :tag "TD"
                             :attr `(("ALIGN"   . ,(align guts))
                                     ("COLSPAN" . ,(colspan guts))
                                     ("VALIGN"  . ,(valign guts))))
            (let ((element (car elements)))
              (typecase element
                (string       (format stream (if (equal element "")
                                                 "&nbsp;"
                                                 element)))
                (number       (format stream "~A" element))
                (html-element (render-html element stream))
                (function     (funcall element)) ;; heck, why not?
                (t            "&nbsp;"))
              (setq elements (cdr elements)))))))))