X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=mop.lisp;h=b24c4b477dac3b1852e894fc3f11c10ffd9d2962;hb=8df04510a35e76a04399872d24ccdfa322a763ff;hp=3075517d85aae7a38ba8172cf7250f253f0f7638;hpb=581bb46d7007c98198cdebec4a7ebf1c2feb81ef;p=hyperobject.git

diff --git a/mop.lisp b/mop.lisp
index 3075517..b24c4b4 100644
--- a/mop.lisp
+++ b/mop.lisp
@@ -11,10 +11,9 @@
 ;;;; in Text, HTML, and XML formats. This includes hyperlinking
 ;;;; capability and sub-objects.
 ;;;;
-;;;; $Id: mop.lisp,v 1.65 2003/04/29 09:24:27 kevin Exp $
-;;;;
-;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
+;;;; $Id: mop.lisp,v 1.71 2003/05/14 05:36:22 kevin Exp $
 ;;;;
+;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
  
 (in-package :hyperobject)
@@ -29,6 +28,9 @@
    (user-name :initarg :user-name :type string :initform nil
 	      :accessor user-name
 	      :documentation "User name for class")
+   (user-name-plural :initarg :user-name-plural :type string :initform nil
+		     :accessor user-name-plural
+		     :documentation "Plural 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")
@@ -237,6 +239,7 @@
 	 :hyperlink-parameters (slot-value dsd 'hyperlink-parameters)
 	 :description (slot-value dsd 'description)
 	 :user-name (slot-value dsd 'user-name)
+	 :user-name-plural (slot-value dsd 'user-name-plural)
 	 :index (slot-value dsd 'index)
 	 :value-constraint (slot-value dsd 'value-constraint)
 	 :null-allowed (slot-value dsd 'null-allowed)
@@ -244,12 +247,17 @@
 
 (defmethod compute-effective-slot-definition :around ((cl hyperobject-class) #+ho-normal-cesd name dsds)
   #+ho-normal-cesd (declare (ignore name))
-  (let ((esd (call-next-method)))
+  (let* ((esd (call-next-method))
+	 (dsd (car dsds))
+	 (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 esd 'sql-type) sql-type)
       (setf (slot-value esd 'length) length)
       (setf (slot-value esd 'type) (value-type-to-lisp-type value-type))
-      (setf (slot-value esd 'value-type)  (canonicalize-value-type (slot-value (car dsds) 'value-type)))
+      (setf (slot-value esd 'value-type) value-type)
+      (dolist (name '(print-formatter subobject hyperlink hyperlink-parameters
+		      description value-constraint index null-allowed user-name))
+	(setf (slot-value esd name) (slot-value dsd name)))
       esd)))
 
 
@@ -260,6 +268,10 @@
 #+ho-normal-esdc
 (setq cl:*features* (delete :ho-normal-esdc cl:*features*))
 
+(defun lisp-type-is-a-string (type)
+  (or (eq type 'string)
+      (and (listp type) (some #'(lambda (x) (eq x 'string)) type))))
+
 (defun value-type-to-lisp-type (value-type)
   (case (if (atom value-type)
 	    value-type
@@ -393,19 +405,29 @@
 	  #-(or cmu sbcl) (nreverse subobjects)
 	  )))
 
+
+(defun finalize-class-slots (cl)
+  "Make sure all class slots have an expected value"
+  (unless (user-name cl)
+    (setf (user-name cl) (format nil "~:(~A~)" (class-name cl))))
+  
+  (setf (user-name-plural cl)
+	(if (and (consp (user-name cl)) (cadr (user-name cl)))
+	    (cadr (user-name cl))
+	    (format nil "~A~P" (if (consp (user-name cl))
+				   (car (user-name cl))
+				   (user-name cl))
+		    2)))
+
+  (dolist (name '(user-name description))
+    (awhen (slot-value cl name)
+	   (setf (slot-value cl name)
+		 (etypecase (slot-value cl name)
+		   (cons (car it))
+		   ((or string symbol) it))))))
+
 (defun finalize-documentation (cl)
   "Calculate class documentation slot"
-  (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)
-	       (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"
@@ -441,6 +463,7 @@
   (finalize-hyperlinks cl)
   (finalize-sql cl)
   (finalize-rules cl)
+  (finalize-class-slots cl)
   (finalize-documentation cl))
 
 
@@ -452,10 +475,10 @@
   (find name (class-slots cl) :key #'slot-definition-name))
 
 (defun hyperobject-class-user-name (obj)
-  (awhen (user-name (class-of obj))
-	 (if (consp it)
-	     (car it)
-	     it)))
+  (user-name (class-of obj)))
+
+(defun hyperobject-class-user-name-plural (obj)
+  (user-name-plural (class-of obj)))
 
 (defun hyperobject-class-subobjects (obj)
   (subobjects (class-of obj)))