[Changed behavior of standard-presentation significantly
clinton@unknownlamer.org**20071008235438] {
hunk ./src/standard-presentation-class.lisp 1
-;; Copyright (c) 2003-2005 Edward Marco Baringer
+;; Copyright (c) 2007 Clinton Ebadi
+;; Portions Copyright (c) 2003-2005 Edward Marco Baringer
hunk ./src/standard-presentation-class.lisp 40
-;; This is essentially yanked directly with minor textual changes to
-;; do s/components/presentations/ from standard-component-class.lisp
-;; in UCW.
+;; Some of this is based heavily on the standard-component-class
+;; methods
hunk ./src/standard-presentation-class.lisp 59
-	 (dolist (slot (mopp:class-slots presentation-class))
-	   (if (and (typep slot 'standard-presentation-effective-slot)
-		    (slot-boundp slot 'presentation))
-	       (push (mopp:slot-definition-name slot)
-		     (presentation-slots presentation-class))))))
+	 (setf (presentation-slots presentation-class)
+	       (mapcar
+		#'(lambda (slot) (cons (mopp:slot-definition-name slot)
+				  slot))
+		(remove-if-not
+		 #'(lambda (slot)
+		     (and (typep slot 'standard-presentation-effective-slot)
+			  (slot-boundp slot 'presentation)))
+		 (mopp:class-slots presentation-class))))))
hunk ./src/standard-presentation-class.lisp 82
-  (flet ((presentation-slot->component-slot (slot)
-	   (cond ((null slot) nil)
-		 ((listp slot)
-		  `(,(find-slot-presentation-class-name (car slot)) ,@(cdr slot)))
-		 (t (find-slot-presentation-class-name slot)))))
+  (labels ((find-presentation-class-name (name)
+	     (class-name (ie-type-class name)))
+	   (presentation-slot->component-slot (slot)
+	     (cond ((null slot) nil)
+		   ((listp slot)
+		    `(,(find-presentation-class-name (car slot)) ,@(cdr slot)))
+		   (t (find-presentation-class-name slot)))))
hunk ./src/standard-presentation-class.lisp 106
-
hunk ./src/standard-presentation-class.lisp 128
-;; Move to presentations.lisp later
+;;; Standard Object Presentation
+;; A standard-object-presentation presents a CLOS class and
+;; automatically sets the instances of its child presentations to
+;; slots of the class, or uses an arbitrary reader/writer function on
+;; the parent object
+
+(defclass standard-object-presentation-class (standard-presentation-class)
+  ())
+
+(defclass standard-object-presentation-direct-slot
+    (standard-presentation-direct-slot)
+  ((slot-name :initarg :slot-name :accessor slot-name)
+   (getter :initarg :getter :accessor getter)
+   (setter :initarg :setter :accessor setter)
+   (slot-presentation-p :reader slot-presentation-p :initform nil)))
+
+(defclass standard-object-presentation-effective-slot
+    (standard-presentation-effective-slot)
+  ((getter :initarg :getter :accessor getter)
+   (setter :initarg :setter :accessor setter)
+   (slot-presentation-p :reader slot-presentation-p :initform nil)))
+
+(defmethod mopp:validate-superclass ((class standard-object-presentation-class)
+                                     (superclass mopp:standard-class))
+  t)
+
+(defmethod initialize-instance :after
+    ((slot standard-object-presentation-direct-slot)
+     &key slot-name getter setter &allow-other-keys)
+  (assert (or (xor slot-name (or getter setter))
+	      (not (or slot-name getter setter)))
+	  (slot-name getter setter)
+	  "Must specify either a slot name, or a getter and a setter")
+  (cond ((not (or slot-name getter setter)) slot) ; not a slot presentation
+	((not slot-name)
+	 (assert (and getter setter)
+		 (getter setter)
+		 "Must specify both a getter and a setter")
+	 (setf (slot-value slot 'slot-presentation-p) t))
+	(slot-name (setf (getter slot) #'(lambda (instance)
+					   (if (slot-boundp instance slot-name)
+					       (slot-value instance slot-name)))
+			 (setter slot) #'(lambda (new-value instance)
+					   (setf (slot-value instance slot-name)
+						 new-value))
+			 (slot-value slot 'slot-presentation-p) t))))
+
+(defmethod mopp:direct-slot-definition-class
+    ((class standard-object-presentation-class)
+     &rest initargs)
+  (declare (ignore initargs))
+  (find-class 'standard-object-presentation-direct-slot))
+
+(defmethod mopp:effective-slot-definition-class
+    ((class standard-object-presentation-class)
+     &rest initargs)
+  (declare (ignore initargs))
+  (find-class 'standard-object-presentation-effective-slot))
hunk ./src/standard-presentation-class.lisp 191
-(defmethod presentation-slots ((presentation standard-presentation))
-  (mapcar #'(lambda (slot-name)
-	      (slot-value presentation slot-name))
-	  (presentation-slots (class-of presentation))))
+(defmethod slot-presentations ((class standard-object-presentation-class))
+  (remove-if-not #'(lambda (slot-info)
+		     (slot-presentation-p (cdr slot-info)))
+		 (presentation-slots class)))
}