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 (action-with-isolation-support 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 (defmethod ucw-core:handle-action :wrap-around ((action lisp-on-lines-action) application session frame)
  48      (let ((lol::*invalid-objects* (make-hash-table)))
  49        (handler-bind ((lol::validation-condition
  50                        (lambda (c)
  51                          (let ((object (lol::validation-condition-object c))
  52                                (attribute (lol::validation-condition-attribute c)))
  53
  54
  55                            (setf (gethash object lol::*invalid-objects*)
  56                                  (cons (cons attribute c)
  57                                        (gethash object lol::*invalid-objects*)))))))
  58        (call-next-method))))
  59
  60 (defclass described-component-class (described-class standard-component-class)
  61   ())
  62
  63
  64
  65
  66
  67
  68
  69
  70
  71
  72
  73
  74 ;; (defcomponent standard-window-component
  75 ;;   (ucw-standard::basic-window-component)
  76 ;;   ((body
  77 ;;     :initform nil
  78 ;;     :accessor window-body
  79 ;;     :component t
  80 ;;     :initarg :body)))
  81
  82 ;; (defmethod render-html-head ((window standard-window-component))
  83 ;;   (let* ((app (context.application *context*))
  84 ;;       (url-prefix (application.url-prefix app)))
  85 ;;     (<:meta :http-equiv "Content-Type" :content (window-component.content-type window))
  86 ;;     (awhen (window-component.title window)
  87 ;;       (<:title (if (functionp it)
  88 ;;                 (funcall it window)
  89 ;;                 (<:as-html it))))
  90 ;;     (awhen (window-component.icon window)
  91 ;;       (<:link :rel "icon"
  92 ;;            :type "image/x-icon"
  93 ;;            :href (concatenate 'string url-prefix it)))
  94 ;;     (dolist (stylesheet (effective-window-stylesheets window))
  95 ;;       (<:link :rel "stylesheet"
  96 ;;            :href stylesheet
  97 ;;            :type "text/css"))))
  98
  99 ;; (defmethod render-html-body ((window standard-window-component))
 100 ;;   (render (window-body window)))
 101
 102 ;; (defcomponent info-message ()
 103 ;;   ((message :accessor message :initarg :message)))
 104
 105 ;; (defmethod render ((m info-message))
 106 ;;   (<:div
 107 ;;    :class "info-mssage"
 108 ;;    (<:as-html (message m)))
 109 ;;    (<ucw:a :action (answer-component m nil) "Ok"))
 110
 111