X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/2b0fd9c886908c6492c66cc30fcacf5fd600bf8e..907c9983f65eac9dd2d2264b02db77d3d8f89c7a:/src/standard-wrappers.lisp

diff --git a/src/standard-wrappers.lisp b/src/standard-wrappers.lisp
dissimilarity index 74%
index bb24876..110bdd3 100644
--- a/src/standard-wrappers.lisp
+++ b/src/standard-wrappers.lisp
@@ -1,54 +1,127 @@
-(in-package :lisp-on-lines)
-
-;;;;; Wrap a display in "back buttons"
-(deflayer wrap-back-buttons)
-
-(defdisplay
-    :in-layer wrap-back-buttons :around
-    (description object)
-    
-    (<ucw:a :class "wiz-button previous" :action (ok component t)
-	    (<:as-html "Go Back"))
-    (<:div :style "clear:both;"
-	   (call-next-method))
-    (<ucw:a :class "wiz-button previous" :action (ok component t)
-	    (<:as-html "Go Back")))
-
-;;;; Wrap an object display in with a link to the object
-
-(deflayer wrap-link)
-
-(defvar *link-wrapped-p* nil)
-
-(define-layered-class description
-  :in-layer wrap-link ()
-  ((link :initarg :link :initform nil :special t :accessor link)))
-
-(defdisplay
-  :in-layer wrap-link :around (description object)
-  (let ((link (link description)))
-
-    (with-inactive-layers (wrap-link)
-      (if *link-wrapped-p*
-	  (call-next-method)
-	  (let ((*link-wrapped-p* t))
-	    (<ucw:a :action (call-display self object link)
-		    (call-next-method)))))))
-
-
-
-;;; wrap-a-form
-(deflayer wrap-form)
-
-(defdisplay ((description t) (button (eql 'standard-form-buttons)))
-  (<ucw:submit :action (ok self)
-	       :value "Ok."))
-
-(defdisplay :in-layer wrap-form :around (object description)
-  (<ucw:form
-   :action (refresh-component self)
-   (with-inactive-layers (wrap-form)
-
-     (call-next-method)
-     ;(display* 'standard-form-buttons)
-   )))
\ No newline at end of file
+(in-package :lisp-on-lines)
+
+;;;;; Wrap a display in "back buttons"
+(deflayer wrap-back-buttons)
+
+(defvar *back-buttons-wrapped-p* nil)
+
+(defdisplay
+  :in-layer wrap-back-buttons :around
+  (description object)
+  (if  *back-buttons-wrapped-p*
+       (call-next-method)
+       (let ((*back-buttons-wrapped-p* t))
+	
+	 (<ucw:a :class "wiz-button previous" :action (ok self t)
+		 (<:as-html "Go Back"))
+	 (<:div :style "clear:both;"
+		(call-next-method))
+	 (<ucw:a :class "wiz-button previous" :action (ok self t)
+		 (<:as-html "Go Back")))))
+
+;;;; Wrap an object display in with a link to the object
+
+(deflayer wrap-link)
+
+(defvar *link-wrapped-p* nil)
+
+(define-layered-class description
+  :in-layer wrap-link ()
+  ((link :initarg :link-action
+	 :initarg :action
+	 :initform nil :special t :accessor link-action)))
+
+(defaction call-action-with-component-and-object ((self component) action-id object)
+  (funcall (ucw::find-action (ucw::context.current-frame *context*) action-id)
+	   self
+	   object))
+
+(defdisplay
+    :in-layer wrap-link :around (description object)
+    (let ((link (link-action description)))
+
+      (with-inactive-layers (wrap-link)
+	(if *link-wrapped-p*
+	    (call-next-method)
+	    (let ((*link-wrapped-p* t))
+	      (<ucw:a :action (call-action-with-component-and-object
+			       self
+			       (ucw::make-new-action
+				(ucw::context.current-frame *context*)
+				(if (consp link)
+				    (eval link)
+				    link))
+			       object)
+		      (call-next-method)))))))
+
+;;; wrap-a-form
+(deflayer wrap-form)
+
+(defvar *in-form-p* nil)
+
+(define-layered-class description
+  :in-layer wrap-form ()
+  ((form-buttons :initarg :form-buttons :initform nil :special t :accessor form-buttons)
+   (form-type :initarg :form-type :initform '<ucw:simple-form :special t :accessor form-type)))
+
+(defattribute form-button-attribute ()
+  ((form-buttons :initarg :form-buttons :initform nil :special t :accessor form-buttons)))
+
+(defdisplay ((description form-button-attribute) object)	    
+  (macrolet ((submit (&key action value )
+	       `(<ucw::value-submit
+		 :action (funcall ,action self object)
+		 
+		 :value ,value)))
+    (loop for button in (form-buttons description)
+	 do 
+	 (let ((button button))
+	   (with-properties (button)
+	     (let ((action (.get :action)))
+	       (submit :value (.get :value)
+		       :action (if (consp action)
+				   (eval action)
+				   action))))))))
+
+
+(defdisplay
+  :in-layer wrap-form
+  :around (description object)
+  (flet ((body ()
+	   (with-inactive-layers (wrap-form)
+	     (call-next-method)
+	     (with-inactive-layers (show-attribute-labels)
+	       (display-attribute
+		(make-instance
+		 'form-button-attribute
+		 :form-buttons
+		 (form-buttons description))
+		object)))))
+    (ecase (form-type description)
+      ('<ucw:simple-form
+       (<ucw:simple-form
+	:action (refresh-component self)
+	(body)))
+      ('<ucw:form
+       (<ucw:form
+	:action (refresh-component self)
+	(body))))))
+
+;;;; wrap a DIV
+
+
+(deflayer wrap-div)
+
+(define-layered-class description
+  :in-layer wrap-div ()
+  ((div-attributes :accessor div-attributes :initarg :div :special t :initform nil)))
+
+(defdisplay :in-layer wrap-div :wrap-around (description object)
+ (let ((args (div-attributes description)))
+   (with-inactive-layers (wrap-div)
+     (yaclml::funcall-with-tag
+      (cons '<:div args)
+      (lambda ()
+	(call-next-method))))))
+
+     
\ No newline at end of file