X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/6de8d30004efc9337b8c40d2ff2d0a76651d23eb..HEAD:/src/ucw/standard-components.lisp

diff --git a/src/ucw/standard-components.lisp b/src/ucw/standard-components.lisp
dissimilarity index 96%
index dd39293..62c6fc6 100644
--- a/src/ucw/standard-components.lisp
+++ b/src/ucw/standard-components.lisp
@@ -1,49 +1,111 @@
-(in-package :lisp-on-lines-ucw)
-
-(defclass described-component-class (standard-component-class described-class)
-  ())
-
-(defmacro defaction (&rest args-and-body)
-  `(arnesi:defmethod/cc ,@args-and-body))
-
-(defun make-action (lambda &rest args)
-  (let ((ucw::*default-action-class* 'basic-action))
-    (apply #'ucw::make-action lambda args)))
-
-(defclass standard-application (ucw:basic-application)
-  ())
-
-(defclass standard-request-context (ucw::standard-request-context)
-  ())
-
-(defmethod ucw:request-context-class list ((application standard-application))
-  'standard-request-context)
-
-(defvar +action-compound-name-delimiter+ #\|)
-
-(defmethod ucw::find-action-id :around ((context standard-request-context))
-  (or 
-   (let (id)
-     (ucw::find-parameter 
-      (context.request context) ucw::+action-parameter-name+
-      :test (lambda (name parameter)
-	      (declare (ignore name))
-	      (destructuring-bind (param-name &optional action-id)
-		  (split-sequence:split-sequence 
-		   +action-compound-name-delimiter+ parameter)
-		(when (and action-id 
-			   (string= ucw::+action-parameter-name+ param-name))
-		  (setf id action-id)))))
-     id)
-   (call-next-method)))
-
-(defcomponent standard-window-component 
-  (ucw:basic-window-component)
-  ((body
-    :initform nil
-    :accessor window-body
-    :component t
-    :initarg :body)))
-
-(defmethod render-html-body ((window standard-window-component))
-  (ucw:render (window-body window)))
+(in-package :lisp-on-lines-ucw)
+
+(defclass lisp-on-lines-application (contextl-application)
+  ()
+  (:default-initargs :action-class 'lisp-on-lines-action))
+
+(defclass lisp-on-lines-action (action-with-isolation-support contextl-action ) 
+  ()
+  (:metaclass closer-mop:funcallable-standard-class))
+
+(defclass lisp-on-lines-component (contextl-component) 
+  () 
+  (:metaclass standard-component-class))
+
+(defclass lisp-on-lines-component-class (standard-component-class) 
+  ())
+
+
+(defmethod initialize-instance :around ((class lisp-on-lines-component-class) 
+					&rest initargs &key (direct-superclasses '()))
+  (declare (dynamic-extent initargs))
+  (if (loop for direct-superclass in direct-superclasses
+	 thereis (ignore-errors (subtypep direct-superclass 'lisp-on-lines-component)))
+      (call-next-method)
+      (apply #'call-next-method
+	     class
+	     :direct-superclasses
+	     (append direct-superclasses
+		     (list (find-class 'lisp-on-lines-component)))
+	     initargs)))
+
+
+(defmethod reinitialize-instance :around ((class lisp-on-lines-component-class) 
+					  &rest initargs &key (direct-superclasses '() direct-superclasses-p))
+  (declare (dynamic-extent initargs))
+  (if (or (not direct-superclasses-p)
+	  (loop for direct-superclass in direct-superclasses
+	     thereis (ignore-errors (subtypep direct-superclass 'lisp-on-lines-component))))
+      (call-next-method)
+      (apply #'call-next-method
+	     class
+	     :direct-superclasses
+	     (append direct-superclasses
+		     (list (find-class 'lisp-on-lines-component)))
+	     initargs)))
+
+(defmethod ucw-core:handle-action :wrap-around ((action lisp-on-lines-action) application session frame)
+     (let ((lol::*invalid-objects* (make-hash-table)))
+       (handler-bind ((lol::validation-condition 
+		       (lambda (c)
+			 (let ((object (lol::validation-condition-object c))
+			       (attribute (lol::validation-condition-attribute c)))
+
+
+			   (setf (gethash object lol::*invalid-objects*)
+				 (cons (cons attribute c)
+				       (gethash object lol::*invalid-objects*)))))))
+       (call-next-method))))
+
+(defclass described-component-class (described-class standard-component-class)
+  ())
+
+
+
+
+
+
+
+
+
+
+
+
+;; (defcomponent standard-window-component 
+;;   (ucw-standard::basic-window-component)
+;;   ((body
+;;     :initform nil
+;;     :accessor window-body
+;;     :component t
+;;     :initarg :body)))
+
+;; (defmethod render-html-head ((window standard-window-component))
+;;   (let* ((app (context.application *context*))
+;; 	 (url-prefix (application.url-prefix app)))
+;;     (<:meta :http-equiv "Content-Type" :content (window-component.content-type window))
+;;     (awhen (window-component.title window)
+;;       (<:title (if (functionp it)
+;; 		   (funcall it window)
+;; 		   (<:as-html it))))
+;;     (awhen (window-component.icon window)
+;;       (<:link :rel "icon"
+;; 	      :type "image/x-icon"
+;; 	      :href (concatenate 'string url-prefix it)))
+;;     (dolist (stylesheet (effective-window-stylesheets window))
+;;       (<:link :rel "stylesheet"
+;; 	      :href stylesheet
+;; 	      :type "text/css"))))
+
+;; (defmethod render-html-body ((window standard-window-component))
+;;   (render (window-body window)))
+
+;; (defcomponent info-message ()
+;;   ((message :accessor message :initarg :message)))
+
+;; (defmethod render ((m info-message))
+;;   (<:div
+;;    :class "info-mssage" 
+;;    (<:as-html (message m)))
+;;    (<ucw:a :action (answer-component m nil) "Ok"))
+
+