src/ucw/standard-components.lisp

   1 (in-package :lisp-on-lines-ucw)
   2
   3 (defclass lisp-on-lines-application (contextl-application)
   4   ()
   5   (:default-initargs :action-class 'lisp-on-lines-action))
   6
   7 (defclass lisp-on-lines-action (contextl-action)
   8   ()
   9   (:metaclass closer-mop:funcallable-standard-class))
  10
  11 (defclass lisp-on-lines-component (contextl-component)
  12   ()
  13   (:metaclass standard-component-class))
  14
  15 (defclass lisp-on-lines-component-class (standard-component-class)
  16   ())
  17
  18
  19 (defmethod initialize-instance :around ((class lisp-on-lines-component-class)
  20                                         &rest initargs &key (direct-superclasses '()))
  21   (declare (dynamic-extent initargs))
  22   (if (loop for direct-superclass in direct-superclasses
  23          thereis (ignore-errors (subtypep direct-superclass 'lisp-on-lines-component)))
  24       (call-next-method)
  25       (apply #'call-next-method
  26              class
  27              :direct-superclasses
  28              (append direct-superclasses
  29                      (list (find-class 'lisp-on-lines-component)))
  30              initargs)))
  31
  32
  33 (defmethod reinitialize-instance :around ((class lisp-on-lines-component-class)
  34                                           &rest initargs &key (direct-superclasses '() direct-superclasses-p))
  35   (declare (dynamic-extent initargs))
  36   (if (or (not direct-superclasses-p)
  37           (loop for direct-superclass in direct-superclasses
  38              thereis (ignore-errors (subtypep direct-superclass 'lisp-on-lines-component))))
  39       (call-next-method)
  40       (apply #'call-next-method
  41              class
  42              :direct-superclasses
  43              (append direct-superclasses
  44                      (list (find-class 'lisp-on-lines-component)))
  45              initargs)))
  46
  47 (defclass described-component-class (described-class standard-component-class )
  48   ())
  49
  50
  51
  52
  53 (defmethod ucw-core:handle-action :wrap-around ((action lisp-on-lines-action) application session frame)
  54      (let ((lol::*invalid-objects* (make-hash-table)))
  55        (handler-bind ((lol::validation-condition
  56                        (lambda (c)
  57                          (let ((object (lol::validation-condition-object c))
  58                                (attribute (lol::validation-condition-attribute c)))
  59
  60
  61                            (setf (gethash object lol::*invalid-objects*)
  62                                  (cons (cons attribute c)
  63                                        (gethash object lol::*invalid-objects*)))))))
  64        (call-next-method))))
  65
  66
  67
  68
  69
  70
  71
  72
  73 (defclass described-component-class (described-class standard-component-class )
  74   ())
  75
  76
  77
  78 ;; (defcomponent standard-window-component
  79 ;;   (ucw-standard::basic-window-component)
  80 ;;   ((body
  81 ;;     :initform nil
  82 ;;     :accessor window-body
  83 ;;     :component t
  84 ;;     :initarg :body)))
  85
  86 ;; (defmethod render-html-head ((window standard-window-component))
  87 ;;   (let* ((app (context.application *context*))
  88 ;;       (url-prefix (application.url-prefix app)))
  89 ;;     (<:meta :http-equiv "Content-Type" :content (window-component.content-type window))
  90 ;;     (awhen (window-component.title window)
  91 ;;       (<:title (if (functionp it)
  92 ;;                 (funcall it window)
  93 ;;                 (<:as-html it))))
  94 ;;     (awhen (window-component.icon window)
  95 ;;       (<:link :rel "icon"
  96 ;;            :type "image/x-icon"
  97 ;;            :href (concatenate 'string url-prefix it)))
  98 ;;     (dolist (stylesheet (effective-window-stylesheets window))
  99 ;;       (<:link :rel "stylesheet"
 100 ;;            :href stylesheet
 101 ;;            :type "text/css"))))
 102
 103 ;; (defmethod render-html-body ((window standard-window-component))
 104 ;;   (render (window-body window)))
 105
 106 ;; (defcomponent info-message ()
 107 ;;   ((message :accessor message :initarg :message)))
 108
 109 ;; (defmethod render ((m info-message))
 110 ;;   (<:div
 111 ;;    :class "info-mssage"
 112 ;;    (<:as-html (message m)))
 113 ;;    (<ucw:a :action (answer-component m nil) "Ok"))
 114
 115