r5292: *** empty log message ***

diff --git a/mop.lisp b/mop.lisp
index 48f7cc92902e007f7f3bbc669720d7c7eff1fa63..4ea60683b33184e8e93e2d66b54380639512baf1 100644 (file)
--- a/mop.lisp
+++ b/mop.lisp
@@ -11,7 +11,7 @@
 ;;;; in Text, HTML, and XML formats. This includes hyperlinking\r
 ;;;; capability and sub-objects.\r
 ;;;;\r
-;;;; $Id: mop.lisp,v 1.82 2003/07/08 07:12:57 kevin Exp $\r
+;;;; $Id: mop.lisp,v 1.83 2003/07/11 18:02:41 kevin Exp $\r
 ;;;;\r
 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg\r
 ;;;; *************************************************************************\r
@@ -56,6 +56,9 @@
    (direct-rules :type list :initform nil :initarg :direct-rules\r
                 :accessor direct-rules\r
                 :documentation "List of rules to fire on slot changes.")\r
+   (direct-views :type list :initform nil :initarg :direct-views\r
+                :accessor direct-views\r
+                :documentation "List of views")\r
    (class-id :type integer :initform nil\r
             :accessor class-id\r
             :documentation "Unique ID for the class")\r
@@ -474,7 +477,8 @@ SQL name"
                                   (user-name cl))\r
                    2)))\r
 \r
-  (dolist (name '(user-name description version guid sql-name))\r
+  (dolist (name '(user-name description version guid sql-name\r
+                 direct-views direct-rules))\r
     (awhen (slot-value cl name)\r
           (setf (slot-value cl name)\r
                 (etypecase (slot-value cl name)\r

diff --git a/views.lisp b/views.lisp
index b21a18e6c26da0ee0b6b151e279db1d049e903d9..6c102965ef1cbfef5b86a54fe61c4777d48c93bc 100644 (file)
--- a/views.lisp
+++ b/views.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: views.lisp,v 1.59 2003/06/29 16:21:09 kevin Exp $
+;;;; $Id: views.lisp,v 1.60 2003/07/11 18:02:41 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -16,10 +16,7 @@
 
 
 (defclass object-view ()
-  ((object-class-name :initform nil :initarg :object-class-name
-                     :accessor object-class-name
-                :documentation "Name of class of object to be viewed.")
-   (object-class :initform nil :initarg :object-class
+  ((object-class :initform nil :initarg :object-class
                 :accessor object-class
                 :documentation "Class of object to be viewed.")
    (slots :initform nil :initarg :slots :accessor slots
@@ -32,6 +29,8 @@
                :documentation "Source code for generating view.")
    (country-language :initform :en :initarg :country-language
                     :documentation "Country's Language for this view.")
+   (printer :initform nil :initarg :printer :accessor printer
+           :documentation "default function that prints the object")
    ;;
    (file-start-str :type (or string null) :initform nil :initarg :file-start-str
                   :accessor file-start-str)
@@ -105,10 +104,9 @@
             it
             (let ((view
                    (make-instance 'object-view
-                                  :object-class-name (class-name obj-class)
-                                  :object-class obj-class
-                                  :category category
-                                  :slots slots)))
+                     :object-class (find-class obj-class)
+                     :category category
+                     :slots slots)))
               (push view (views obj-class))
               view)))))
                             
@@ -122,14 +120,12 @@
     (setf (default-print-slots cl)
          (mapcar #'slot-definition-name (class-slots cl))))
   (let ((views '()))
-    (dolist (view-def (views cl))
+    (dolist (view-def (direct-views cl))
       (push (make-object-view cl view-def) views))
     (setf (views cl) (nreverse views)))
   (cond
-    ((default-view cl)
-     (setf (default-view cl) (make-object-view cl (default-view cl))))
-    ((car (views cl))
-     (setf (default-view cl) (make-object-view cl (car (views cl)))))
+    ((views cl)
+     (setf (default-view cl) (car (views cl))))
     (t
      (setf (default-view cl) (make-object-view cl :default)))))
 
@@ -141,36 +137,44 @@
     ((eq view-def :default)
      (let* ((name (class-name cl))
            (view (make-instance 'object-view :name "automatic"
-                                :object-class-name name
-                                :object-class cl
+                                :object-class (class-name cl)
                                 :category :compact-text)))
        view))
     ((consp view-def)
-     (apply #'make-instance 'object-view view-def))
+     (make-instance 'object-view
+                   :object-class (class-name cl)
+                   :name (getf view-def :name)
+                   :source-code (getf view-def :source-code)))
     (t
      (error "Invalid parameter to make-object-view: ~S" view-def))))
 
-(defmethod initialize-instance :after ((view object-view)
-                                      &rest initargs &key &allow-other-keys)
-  (initialize-view (object-class view) view))
+(defmethod initialize-instance :after ((self object-view)
+                                      &rest initargs 
+                                      &key 
+                                      &allow-other-keys)
+  (initialize-view self))
   
-(defun initialize-view (obj-cl view)
+(defun initialize-view (view)
   "Calculate all view slots for a hyperobject class"
-  (cond
-    ((category view)
-     (initialize-view-by-category obj-cl view))
-    ((source-code view)
-     (initialize-view-by-source-code obj-cl view))
-    (t
-     (setf (category view) :compact-text)
-     (initialize-view-by-category obj-cl view))))
-
-(defun initialize-view-by-source-code (obj-cl view)
+  (let ((obj-cl (find-class (object-class view))))
+    (cond
+     ((category view)
+      (initialize-view-by-category obj-cl view))
+     ((source-code view)
+      (initialize-view-by-source-code view))
+     (t
+      (setf (category view) :compact-text)
+      (initialize-view-by-category obj-cl view)))))
+
+(defun initialize-view-by-source-code (view)
   "Initialize a view based upon a source code"
-  (let ((source-code (source-code view)))
-    (warn "source code compilation is not implemented")
-    )
-  )
+  (let* ((source-code (source-code view))
+        (*package* (symbol-package (object-class view)))
+        (printer `(lambda (x s)
+                    (declare (ignorable x s))
+                    ,@source-code)))
+    (setf (printer view) 
+      (compile nil (eval printer)))))
 
 (defmacro write-simple (v s)
   `(typecase ,v
@@ -652,7 +656,18 @@
             (load-all-subobjects it))))
   objs)
 
-(defun view-hyperobject (objs view category strm &optional (indent 0) filter
+(defun view-subobjects (obj strm &optional category (indent 0) filter
+                       subobjects refvars link-printer)
+  (when (hyperobject-class-subobjects obj)
+    (dolist (subobj (hyperobject-class-subobjects obj))
+      (aif (slot-value obj (name-slot subobj))
+          (view-hyperobject
+           it (get-category-view (car (mklist it)) category)
+           category strm (1+ indent) filter subobjects refvars
+           link-printer)))))
+
+         
+(defun view-hyperobject (objs view strm &optional category (indent 0) filter
                         subobjects refvars link-printer)
   "Display a single or list of hyperobject-class instances and their subobjects"
   (let-when (objlist (mklist objs))
@@ -665,20 +680,17 @@
          (*print-level* nil))
       (fmt-list-start (car objlist) view strm indent nobjs)
       (dolist (obj objlist)
-        (unless (and filter (not (funcall filter obj)))
-          (fmt-obj-start obj view strm indent)
-          (fmt-obj-data obj view strm (1+ indent) refvars link-printer)
-          (fmt-obj-end obj view strm indent)
-          (fmt-subobj-start obj view strm indent)
-          (when (and subobjects (hyperobject-class-subobjects obj))
-           (dolist (subobj (hyperobject-class-subobjects obj))
-             (aif (slot-value obj (name-slot subobj))
-                  (view-hyperobject it
-                                    (get-category-view (car (mklist it))
-                                                       category)
-                                    category strm (1+ indent) filter
-                                    subobjects refvars link-printer))))
-         (fmt-subobj-end obj view strm indent)))
+       (awhen (printer view)
+              (funcall it obj strm))
+       (unless (and filter (not (funcall filter obj)))
+         (fmt-obj-start obj view strm indent)
+         (fmt-obj-data obj view strm (1+ indent) refvars link-printer)
+         (fmt-obj-end obj view strm indent)
+         (when subobjects 
+           (fmt-subobj-start obj view strm indent)
+           (view-subobjects obj category strm indent filter subobjects
+                            refvars link-printer)
+           (fmt-subobj-end obj view strm indent))))
       (fmt-list-end (car objlist) view strm indent nobjs)))
   objs)
 
@@ -693,7 +705,7 @@
       (setq view (default-view (class-of (car objlist)))))
     (when file-wrapper
       (fmt-file-start view stream))
-    (view-hyperobject objlist view category stream 0 filter subobjects refvars
+    (view-hyperobject objlist view stream category 0 filter subobjects refvars
                      link-printer)
     (when file-wrapper
       (fmt-file-end view stream)))