X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=mop.lisp;h=1094c56f0fd4595ab9b97dc7db90a14f6be3bd71;hb=da95022a6396191e772e59cd7622c7c5919ce605;hp=960195134da2aa579e99cfc055f4be8b70c9d4d3;hpb=cda49a13fa66d935f4d7db644364cc741b9c1c4c;p=hyperobject.git

diff --git a/mop.lisp b/mop.lisp
index 9601951..1094c56 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.2 2002/11/29 05:05:29 kevin Exp $
+;;;; $Id: mop.lisp,v 1.10 2002/12/13 05:44:19 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -20,61 +20,64 @@
 (in-package :hyperobject)
 
 (eval-when (:compile-toplevel :execute)
-  (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))))
+  (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2))))
 
 ;; Main class
 
 (defclass hyperobject-class (standard-class)
   ( ;; slots initialized in defclass
-   (title :initarg :title :type string :initform nil
-	  :documentation "Print Title for class")
-   (print-slots :initarg :print-slots :type list :initform nil
-		:documentation "List of slots to print")
+   (user-name :initarg :user-name :type string :initform nil
+	  :documentation "User name for class")
+   (default-print-slots :initarg :default-print-slots :type list :initform nil
+			:documentation "Defaults slots for a view")
    (description :initarg :description :initform nil
 		:documentation "Class description")
    (version :initarg :version :initform nil
 		:documentation "Version number for class")
+   (sql-name :initarg :table-name :initform nil)
 
    ;;; The remainder of these fields are calculated one time
    ;;; in finalize-inheritence.
    
    (subobjects :initform nil :documentation
 	       "List of fields that contain a list of subobjects objects.")
-   (references :type list :initform nil :documentation 
-	       "List of fields that have references")
+   (hyperlinks :type list :initform nil :documentation 
+	       "List of fields that have hyperlinks")
    (class-id :type integer :initform nil :documentation
 	     "Unique ID for the class")
-   
-   (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)
+
+   ;; 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)
+
+   (views :type list :initform nil :initarg :views :accessor views
+	  :documentation "List of views")
+   (default-view :initform nil :initarg :default-view :accessor default-view
+		 :documentation "The default view for a class")
    )
   (:documentation "Metaclass for Markup Language classes."))
 
 (defclass subobject ()
-  ((name :type symbol :initform nil :initarg :name :reader name)
-   (reader :type function :initform nil :initarg :reader :reader reader)))
+  ((name-class :type symbol :initform nil :initarg :name-class :reader name-class)
+   (name-slot :type symbol :initform nil :initarg :name-slot :reader name-slot)
+   (lookup :type symbol :initform nil :initarg :lookup :reader lookup)
+   (lookup-keys :type list :initform nil :initarg :lookup-keys
+		:reader lookup-keys))
+  (:documentation "Contains subobject information"))
+
 
 (defmethod print-object ((obj subobject) (s stream))
   (print-unreadable-object (obj s :type t :identity t)
     (format s "~S" (name obj))))
 
-(defclass reference ()
+(defclass hyperlink ()
   ((name :type symbol :initform nil :initarg :name :reader name)
    (lookup :type function :initform nil :initarg :lookup :reader lookup)
    (link-parameters :type list :initform nil :initarg :link-parameters
 		    :reader link-parameters)))
 
-(defmethod print-object ((obj reference) (s stream))
+(defmethod print-object ((obj hyperlink) (s stream))
   (print-unreadable-object (obj s :type t :identity t)
     (format s "~S" (name obj))))
 
@@ -83,7 +86,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) 
@@ -145,108 +149,179 @@
 			:initform nil))
 		  (append *slot-options* *slot-options-no-initarg*)))))
   ) ;; eval-when
-  
+
+(defun intern-in-keyword (obj)
+  (cond
+    ((null obj)
+     nil)
+    ((eq t obj)
+     t)
+    ((atom obj)
+     (intern (symbol-name obj) (find-package 'keyword)))
+    ((consp obj)
+     (cons (intern-in-keyword (car obj) ) (intern-in-keyword (cdr obj))))
+    (t
+     obj)))
+
 (defmethod compute-effective-slot-definition :around
     ((cl hyperobject-class) #+(or allegro lispworks) name dsds)
   #+allergo (declare (ignore name))
   (let* ((dsd (car dsds))
-	 (ho-type (slot-value dsd 'type)))
+	 (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))
-    (setf (slot-value dsd 'sql-type) (ho-type-to-sql-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)
-       :reference (slot-value dsd 'reference)
+       :hyperlink (slot-value dsd 'hyperlink)
+       :hyperlink-parameters (slot-value dsd 'hyperlink-parameters)
        :description (slot-value dsd 'description)
-       ia)))
-  )
+       :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 (intern (symbol-name ho-type) (symbol-name :keyword))
-    (:string
+  (case ho-type
+    ((or :string :cdata :varchar :char)
      'string)
+    (:character
+     'character)
     (:fixnum
      'fixnum)
     (:boolean
      'boolean)
     (:integer
      'integer)
-    (:cdata
-     'string)
-    (:float
-     'float)
-    (:nil
+    ((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 (intern (symbol-name ho-type) (symbol-name :keyword))
-    (:string
+  (case ho-type
+    ((or :string :cdata)
      'string)
     (:fixnum
-     'fixnum)
+     'integer)
     (:boolean
      'boolean)
     (:integer
      'integer)
-    (:cdata
-     'string)
-    (:float
-     'float)
-    (:nil
+    ((or :float :single-float)
+     'single-float)
+    (:double-float
+     'double-float)
+    (nil
      t)
     (otherwise
      ho-type)))
 
+
 ;;;; Class initialization function
 
-(defun process-subobjects (cl)
+;; defines a slot-unbound method for class and slot-name, fills
+;; the slot by calling reader function with the slot values of
+;; the instance's reader-keys
+(defmacro def-lazy-reader (class slot-name reader &rest reader-keys)
+  (let* ((the-slot-name (gensym))
+	 (the-class (gensym))
+	 (the-instance (gensym))
+	 (keys '()))
+    (dolist (key reader-keys)
+      (push (list 'slot-value the-instance (list 'quote key)) keys))
+    (setq keys (nreverse keys))
+    `(defmethod slot-unbound (,the-class (,the-instance ,class)
+					 (,the-slot-name (eql ',slot-name)))
+       (declare (ignore ,the-class))
+       (setf (slot-value ,the-instance ,the-slot-name)
+	   (,reader ,@keys)))))
+
+(defun finalize-subobjects (cl)
   "Process class subobjects slot"
   (setf (slot-value cl 'subobjects)
     (let ((subobjects '()))
       (dolist (slot (class-slots cl))
-	(when (slot-value slot 'subobject)
-	  (push (make-instance 'subobject :name (slot-definition-name slot)
-			       :reader (if (eq t (slot-value slot 'subobject))
-					   (slot-definition-name slot)
-					 (slot-value slot 'subobject)))
-		subobjects)))
+	(let-when (subobj-def (slot-value slot 'subobject))
+          (let ((subobject (make-instance 'subobject
+					  :name-class (class-name cl)
+					  :name-slot (slot-definition-name slot)
+					  :lookup (if (atom subobj-def)
+						      subobj-def
+						      (car subobj-def))
+					  :lookup-keys (if (atom subobj-def)
+							   nil
+							   (cdr subobj-def)))))
+	    (unless (eq (lookup subobject) t)
+	      (eval `(def-lazy-reader ,(name-class subobject)
+			 ,(name-slot subobject) ,(lookup subobject)
+			 ,@(lookup-keys subobject))))
+	    (push subobject subobjects))))
       subobjects)))
 
-(defun process-documentation (cl)
+(defun finalize-documentation (cl)
   "Calculate class documentation slot"
-  (awhen (slot-value cl 'title)
-	 (setf (slot-value cl 'title) (car it)))
+  (awhen (slot-value cl 'user-name)
+	 (setf (slot-value cl 'user-name)
+	       (etypecase (slot-value cl 'user-name)
+		   (cons (car it))
+		   ((or string symbol) it))))
   (awhen (slot-value cl 'description)
-	 (setf (slot-value cl 'description) (car it)))
-  
+	 (setf (slot-value cl 'description)
+	       (etypecase (slot-value cl 'description)
+		   (cons (car it))
+		   ((or string symbol) it))))
+
   (let ((*print-circle* nil))
     (setf (documentation (class-name cl) 'class)
       (format nil "Hyperobject~A~A~A~A"
-	      (aif (slot-value cl 'title)
+	      (aif (slot-value cl 'user-name)
 		   (format nil ": ~A" it ""))
 	      (aif (slot-value cl 'description)
 		   (format nil "~%Class description: ~A" it) "")
 	      (aif (slot-value cl 'subobjects)
-		   (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name it)) "")
-	      (aif (slot-value cl 'print-slots)
-		   (format nil "~%Print-slots:~{ ~A~}" it) "")
+		   (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name-slot it)) "")
+	      (aif (slot-value cl 'default-print-slots)
+		   (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"
-  (process-subobjects cl)
-  (process-views cl)
-  (process-documentation cl))
+  (finalize-subobjects cl)
+  (finalize-views cl)
+  (finalize-hyperlinks cl)
+  (finalize-sql cl)
+  (finalize-documentation cl))
 
 
 ;;;; *************************************************************************
@@ -256,56 +331,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))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  
-  (defun hyperobject-class-title (obj)
-    (awhen (slot-value (class-of obj) 'title)
-	   (if (consp it)
-	       (car it)
-	       it))))
+(defun hyperobject-class-user-name (obj)
+  (awhen (slot-value (class-of obj) 'user-name)
+	 (if (consp it)
+	     (car it)
+	     it)))
 
 (defun hyperobject-class-subobjects (obj)
   (slot-value (class-of obj) 'subobjects))
 
-(defun hyperobject-class-references (obj)
-  (slot-value (class-of obj) 'references))
+(defun hyperobject-class-hyperlinks (obj)
+  (slot-value (class-of obj) 'hyperlinks))
 
 (defun hyperobject-class-fields (obj)
   (class-slots (class-of obj)))
 
-(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))
-