X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=mop.lisp;h=f40287473d92d2e75fa272f407b3774e3216ecac;hb=509f5717bbb67f567741531ca7f2b34a9f8939f9;hp=e315843aecc11282fdca3291278f10290f80a8e7;hpb=8c743e4dea6fe52c62c1cdf02a75839654e1427c;p=hyperobject.git

diff --git a/mop.lisp b/mop.lisp
index e315843..f402874 100644
--- a/mop.lisp
+++ b/mop.lisp
@@ -11,7 +11,7 @@
 ;;;; in Text, HTML, and XML formats. This includes hyperlinking
 ;;;; capability and sub-objects.
 ;;;;
-;;;; $Id: mop.lisp,v 1.9 2002/12/09 19:37:54 kevin Exp $
+;;;; $Id: mop.lisp,v 1.21 2003/03/29 07:09:41 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -27,41 +27,45 @@
 (defclass hyperobject-class (standard-class)
   ( ;; slots initialized in defclass
    (user-name :initarg :user-name :type string :initform nil
-	  :documentation "User name for class")
-   (print-slots :initarg :print-slots :type list :initform nil
-		:documentation "List of slots to print")
+	      :accessor user-name
+	      :documentation "User name for class")
+   (default-print-slots :initarg :default-print-slots :type list :initform nil
+			:accessor default-print-slots
+			:documentation "Defaults slots for a view")
    (description :initarg :description :initform nil
+		:accessor description
 		:documentation "Class description")
    (version :initarg :version :initform nil
-		:documentation "Version number for class")
-   (sql-name :initarg :table-name :initform nil)
+	    :accessor version
+	    :documentation "Version number for class")
+   (sql-name :initarg :sql-name :initform nil)
 
    ;;; The remainder of these fields are calculated one time
    ;;; in finalize-inheritence.
    
-   (subobjects :initform nil :documentation
+   (subobjects :initform nil :accessor subobjects
+	       :documentation
 	       "List of fields that contain a list of subobjects objects.")
-   (hyperlinks :type list :initform nil :documentation 
-	       "List of fields that have hyperlinks")
-   (class-id :type integer :initform nil :documentation
-	     "Unique ID for the class")
-   
+   (hyperlinks :type list :initform nil :accessor hyperlinks
+	       :documentation "List of fields that have hyperlinks")
+   (direct-rules :type list :initform nil :initarg :direct-rules
+		 :accessor direct-rules
+		 :documentation "List of rules to fire on slot changes.")
+   (class-id :type integer :initform nil
+	     :accessor class-id
+	     :documentation "Unique ID for the class")
+   (default-view :initform nil :initarg :default-view :accessor default-view
+		 :documentation "The default view for a class")
+
+   ;; SQL commands
    (create-table-cmd :initform nil :reader create-table-cmd)
    (create-indices-cmds :initform nil :reader create-index-cmds)
    (drop-table-cmd :initform nil :reader drop-table-cmd)
 
-   (value-func :initform nil :type function)
-   (xmlvalue-func :initform nil :type function)
-   (fmtstr-text :initform nil :type string)
-   (fmtstr-html :initform nil :type string)
-   (fmtstr-xml :initform nil :type string)
-   (fmtstr-text-labels :initform nil :type string)
-   (fmtstr-html-labels :initform nil :type string)
-   (fmtstr-xml-labels :initform nil :type string)
-   (fmtstr-html-ref :initform nil :type string)
-   (fmtstr-xml-ref :initform nil :type string)
-   (fmtstr-html-ref-labels :initform nil :type string)
-   (fmtstr-xml-ref-labels :initform nil :type string)
+   (views :type list :initform nil :initarg :views :accessor views
+	  :documentation "List of views")
+   (rules :type list :initform nil :initarg :rules :accessor rules
+	  :documentation "List of rules")
    )
   (:documentation "Metaclass for Markup Language classes."))
 
@@ -93,7 +97,8 @@
   t)
 
 (defmethod finalize-inheritance :after ((cl hyperobject-class))
-  (init-hyperobject-class cl))
+  (init-hyperobject-class cl)
+  )
 
 ;; Slot definitions
 (defmethod direct-slot-definition-class ((cl hyperobject-class) 
@@ -144,7 +149,11 @@
 		       `(,(intern (symbol-name x))
 			  :initarg
 			  ,(intern (symbol-name x) (symbol-name :keyword))
-			  :initform nil))
+			  :initform nil
+			  :accessor
+			  ,(intern (concatenate 'string
+						(symbol-name :dsd-)
+						(symbol-name x)))))
 		   *slot-options*))))
   (eval
    `(defclass hyperobject-esd (standard-effective-slot-definition)
@@ -152,8 +161,12 @@
 		     `(,(intern (symbol-name x))
 			:initarg
 			,(intern (symbol-name x) (symbol-name :keyword))
-			:initform nil))
-		  (append *slot-options* *slot-options-no-initarg*)))))
+			:initform nil
+			:accessor
+			,(intern (concatenate 'string
+					      (symbol-name :esd-)
+					      (symbol-name x)))))
+		 (append *slot-options* *slot-options-no-initarg*)))))
   ) ;; eval-when
 
 (defun intern-in-keyword (obj)
@@ -169,38 +182,47 @@
     (t
      obj)))
 
-(defmethod compute-effective-slot-definition :around
-    ((cl hyperobject-class) #+(or allegro lispworks) name dsds)
+(defun canonicalize-value-type (vt)
+  (typecase vt
+    (atom
+     (ensure-keyword vt))
+    (cons
+     (cons (ensure-keyword (car vt)) (cdr vt)))
+    (t
+     t)))
+
+(defmethod compute-effective-slot-definition :around ((cl hyperobject-class)
+						      #+(or allegro lispworks) name
+						      dsds)
   #+allergo (declare (ignore name))
   (let* ((dsd (car dsds))
-	 (ho-type (intern-in-keyword (slot-value dsd 'type)))
-	 (sql-type (ho-type-to-sql-type ho-type))
-	 (length (when (consp ho-type) (cadr ho-type))))
-    (setf (slot-value dsd 'ho-type) ho-type)
-    (setf (slot-value dsd 'sql-type) sql-type)
-    (setf (slot-value dsd 'type) (ho-type-to-lisp-type ho-type))
-    (let ((ia (compute-effective-slot-definition-initargs
-	       cl #+lispworks name dsds)))
-      (apply
-       #'make-instance 'hyperobject-esd 
-       :ho-type ho-type
-       :sql-type sql-type
-       :length length
-       :print-formatter (slot-value dsd 'print-formatter)
-       :subobject (slot-value dsd 'subobject)
-       :hyperlink (slot-value dsd 'hyperlink)
-       :hyperlink-parameters (slot-value dsd 'hyperlink-parameters)
-       :description (slot-value dsd 'description)
-       :user-name (slot-value dsd 'user-name)
-       :index (slot-value dsd 'index)
-       ia))))
-
-(defun ho-type-to-lisp-type (ho-type)
-  (when (consp ho-type)
-    (setq ho-type (car ho-type)))
-  (check-type ho-type symbol)
-  (case ho-type
-    ((or :string :cdata :varchar :char)
+	 (value-type (canonicalize-value-type (slot-value dsd 'value-type))))
+    (multiple-value-bind (sql-type length) (value-type-to-sql-type value-type)
+      (setf (slot-value dsd 'sql-type) sql-type)
+      (setf (slot-value dsd 'type) (value-type-to-lisp-type value-type))
+      (let ((ia (compute-effective-slot-definition-initargs
+		 cl #+lispworks name dsds)))
+	(apply
+	 #'make-instance 'hyperobject-esd 
+	 :value-type value-type
+	 :sql-type sql-type
+	 :length length
+	 :print-formatter (slot-value dsd 'print-formatter)
+	 :subobject (slot-value dsd 'subobject)
+	 :hyperlink (slot-value dsd 'hyperlink)
+	 :hyperlink-parameters (slot-value dsd 'hyperlink-parameters)
+	 :description (slot-value dsd 'description)
+	 :user-name (slot-value dsd 'user-name)
+	 :index (slot-value dsd 'index)
+	 :value-constraint (slot-value dsd 'value-constraint)
+	 :null-allowed (slot-value dsd 'null-allowed)
+	 ia)))))
+  
+(defun value-type-to-lisp-type (value-type)
+  (case (if (atom value-type)
+	    value-type
+	    (car value-type))
+    ((:string :cdata :varchar :char)
      'string)
     (:character
      'character)
@@ -210,37 +232,35 @@
      'boolean)
     (:integer
      'integer)
-    ((or :float :single-float)
-     'single-float)
-    (:double-float
-     'double-float)
-    (nil
-     t)
-    (otherwise
-     ho-type)))
-
-(defun ho-type-to-sql-type (ho-type)
-  (when (consp ho-type)
-    (setq ho-type (car ho-type)))
-  (check-type ho-type symbol)
-  (case ho-type
-    ((or :string :cdata)
-     'string)
-    (:fixnum
-     'integer)
-    (:boolean
-     'boolean)
-    (:integer
-     'integer)
-    ((or :float :single-float)
+    ((:float :single-float)
      'single-float)
     (:double-float
      'double-float)
-    (nil
-     t)
     (otherwise
-     ho-type)))
-
+     t)))
+
+(defun value-type-to-sql-type (value-type)
+  "Return two values, the sql type and field length."
+  (let ((type (if (atom value-type)
+		  value-type
+		  (car value-type)))
+	(length (when (consp value-type)
+		  (cadr value-type))))
+    (values
+     (case type
+       ((:string :cdata)
+	:string)
+       ((:fixnum :integer)
+	:integer)
+       (:boolean
+	:boolean)
+       ((:float :single-float)
+	:single-float)
+       (:double-float
+	:double-float)
+       (otherwise
+	:text))
+     length)))
 
 ;;;; Class initialization function
 
@@ -261,12 +281,35 @@
        (setf (slot-value ,the-instance ,the-slot-name)
 	   (,reader ,@keys)))))
 
+
+(defparameter *queued-definitions-pathname*
+  (make-pathname :directory '(:absolute "tmp")
+		 :name (format nil "hyperobject-def-~d" (get-universal-time))
+		 :type "lisp"))
+(defparameter *queued-definitions-stream* nil)
+
+(defun add-definition (def)
+  (unless *queued-definitions-stream*
+    (setq *queued-definitions-stream* (open *queued-definitions-pathname*
+					    :direction :output
+					    :if-exists :supersede)))
+  (format *queued-definitions-stream* "~A~%" def))
+
+(defun process-queued-definitions ()
+  (when *queued-definitions-stream*
+    (close *queued-definitions-stream*)
+    (compile-file *queued-definitions-pathname*)
+    (load (compile-file-pathname *queued-definitions-pathname*))
+    (delete-file *queued-definitions-pathname*) 
+    (delete-file (compile-file-pathname *queued-definitions-pathname*))
+    (setq *queued-definitions-stream* nil)))
+
 (defun finalize-subobjects (cl)
   "Process class subobjects slot"
-  (setf (slot-value cl 'subobjects)
+  (setf (subobjects cl)
     (let ((subobjects '()))
       (dolist (slot (class-slots cl))
-	(let-when (subobj-def (slot-value slot 'subobject))
+	(let-when (subobj-def (esd-subobject slot))
           (let ((subobject (make-instance 'subobject
 					  :name-class (class-name cl)
 					  :name-slot (slot-definition-name slot)
@@ -277,9 +320,10 @@
 							   nil
 							   (cdr subobj-def)))))
 	    (unless (eq (lookup subobject) t)
-	      (eval `(def-lazy-reader ,(name-class subobject)
-			 ,(name-slot subobject) ,(lookup subobject)
-			 ,@(lookup-keys subobject))))
+	      (add-definition
+	       `(def-lazy-reader ,(name-class subobject)
+		 ,(name-slot subobject) ,(lookup subobject)
+		 ,@(lookup-keys subobject))))
 	    (push subobject subobjects))))
       subobjects)))
 
@@ -299,22 +343,35 @@
   (let ((*print-circle* nil))
     (setf (documentation (class-name cl) 'class)
       (format nil "Hyperobject~A~A~A~A"
-	      (aif (slot-value cl 'user-name)
+	      (aif (user-name cl)
 		   (format nil ": ~A" it ""))
-	      (aif (slot-value cl 'description)
+	      (aif (description cl)
 		   (format nil "~%Class description: ~A" it) "")
-	      (aif (slot-value cl 'subobjects)
+	      (aif (subobjects cl)
 		   (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name-slot it)) "")
-	      (aif (slot-value cl 'print-slots)
-		   (format nil "~%Print-slots:~{ ~A~}" it) "")
+	      (aif (default-print-slots cl)
+		   (format nil "~%Default print slots:~{ ~A~}" it) "")
 	      ))))
 
+(defun finalize-hyperlinks (cl)
+  (let ((hyperlinks '()))
+    (dolist (esd (class-slots cl))
+      (awhen (slot-value esd 'hyperlink)
+        (push
+	 (make-instance 'hyperlink
+			:name (slot-definition-name esd)
+			:lookup it
+			:link-parameters (slot-value esd 'hyperlink-parameters))
+	 hyperlinks)))
+    (setf (slot-value cl 'hyperlinks) hyperlinks)))
+
 (defun init-hyperobject-class (cl)
   "Initialize a hyperobject class. Calculates all class slots"
   (finalize-subobjects cl)
   (finalize-views cl)
   (finalize-hyperlinks cl)
   (finalize-sql cl)
+  (finalize-rules cl)
   (finalize-documentation cl))
 
 
@@ -325,57 +382,18 @@
 (defun find-slot-by-name (cl name)
   (find name (class-slots cl) :key #'slot-definition-name))
 
-(defun hyperobject-class-fmtstr-text (obj)
-  (slot-value (class-of obj) 'fmtstr-text))
-
-(defun hyperobject-class-fmtstr-html (obj)
-  (slot-value (class-of obj) 'fmtstr-html))
-
-(defun hyperobject-class-fmtstr-xml (obj)
-  (slot-value (class-of obj) 'fmtstr-xml))
-
-(defun hyperobject-class-fmtstr-text-labels (obj)
-  (slot-value (class-of obj) 'fmtstr-text-labels))
-
-(defun hyperobject-class-fmtstr-html-labels (obj)
-  (slot-value (class-of obj) 'fmtstr-html-labels))
-
-(defun hyperobject-class-fmtstr-xml-labels (obj)
-  (slot-value (class-of obj) 'fmtstr-xml-labels))
-
-(defun hyperobject-class-value-func (obj)
-  (slot-value (class-of obj) 'value-func))
-
-(defun hyperobject-class-xmlvalue-func (obj)
-  (slot-value (class-of obj) 'xmlvalue-func))
-
 (defun hyperobject-class-user-name (obj)
-  (awhen (slot-value (class-of obj) 'user-name)
+  (awhen (user-name (class-of obj))
 	 (if (consp it)
 	     (car it)
 	     it)))
 
 (defun hyperobject-class-subobjects (obj)
-  (slot-value (class-of obj) 'subobjects))
+  (subobjects (class-of obj)))
 
 (defun hyperobject-class-hyperlinks (obj)
-  (slot-value (class-of obj) 'hyperlinks))
+  (hyperlinks (class-of obj)))
 
 (defun hyperobject-class-fields (obj)
   (class-slots (class-of obj)))
 
-(defun hyperobject-class-print-slots (obj)
-  (slot-value (class-of obj) 'print-slots))
-
-(defun hyperobject-class-fmtstr-html-ref (obj)
-  (slot-value (class-of obj) 'fmtstr-html-ref))
-
-(defun hyperobject-class-fmtstr-xml-ref (obj)
-  (slot-value (class-of obj) 'fmtstr-xml-ref))
-
-(defun hyperobject-class-fmtstr-html-ref-labels (obj)
-  (slot-value (class-of obj) 'fmtstr-html-ref-labels))
-
-(defun hyperobject-class-fmtstr-xml-ref-labels (obj)
-  (slot-value (class-of obj) 'fmtstr-xml-ref-labels))
-