r4923: *** empty log message ***

[hyperobject.git] / mop.lisp

diff --git a/mop.lisp b/mop.lisp
index b34541c11d7982647d1638cda566bd52fb438b38..204412dc39d25f59a844b936b6618320947529c3 100644 (file)
--- 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.70 2003/05/14 05:29:48 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 '(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)))