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

diff --git a/mop.lisp b/mop.lisp
index b34541c..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.69 2003/05/06 22:19:09 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)
@@ -252,8 +255,8 @@
       (setf (slot-value esd 'length) length)
       (setf (slot-value esd 'type) (value-type-to-lisp-type value-type))
       (setf (slot-value esd 'value-type) value-type)
-      (dolist (name '(print-formatter subobject hyperlink hyperlink-parameters description user-name
-		      value-constraint index null-allowed))
+      (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)))
 
@@ -402,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"
@@ -450,6 +463,7 @@
   (finalize-hyperlinks cl)
   (finalize-sql cl)
   (finalize-rules cl)
+  (finalize-class-slots cl)
   (finalize-documentation cl))
 
 
@@ -461,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)))