r4923: *** empty log message ***

diff --git a/base-class.lisp b/base-class.lisp
index 417cbccd935f67e9832b36cb3ca1c11d50e9cfaa..4251cf1e88bdc2f087da3601b357d304ad196307 100644 (file)
--- a/base-class.lisp
+++ b/base-class.lisp
@@ -7,9 +7,9 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: base-class.lisp,v 1.6 2003/05/14 04:28:09 kevin Exp $
+;;;; $Id: base-class.lisp,v 1.7 2003/05/14 05:29:48 kevin Exp $
 ;;;;
-;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
+;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
 
 (in-package :hyperobject)

diff --git a/connect.lisp b/connect.lisp
index d1b3789c91e609cbbce24d459e461a1e2b079c5d..05a873578612048589ffd0f0068458fe28f0347c 100644 (file)
--- a/connect.lisp
+++ b/connect.lisp
@@ -7,10 +7,9 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: connect.lisp,v 1.2 2002/12/02 15:57:17 kevin Exp $
+;;;; $Id: connect.lisp,v 1.3 2003/05/14 05:29:48 kevin Exp $
 ;;;;
-;;;; This file, part of Hyperobject-SQL, is
-;;;;    Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
+;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
 
 (in-package :hyperobject)

diff --git a/examples/person.lisp b/examples/person.lisp
index fe6cbe76e44f362dfb64d3c2fd4992485d09551e..72167072cee6e117a82f335bbbe6dcfb915c3f45 100644 (file)
--- a/examples/person.lisp
+++ b/examples/person.lisp
@@ -9,7 +9,7 @@
 ;;;;
 ;;;; A simple example file for hyperobjects
 ;;;;
-;;;; $Id: person.lisp,v 1.6 2002/12/14 21:52:48 kevin Exp $
+;;;; $Id: person.lisp,v 1.7 2003/05/14 05:29:48 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -34,6 +34,7 @@
   (:default-initargs :first-name "" :last-name "" :dob 0 :resume nil) 
   (:default-print-slots first-name last-name dob resume)
   (:user-name "Person")
+  (:user-name-plural "Persons")
   (:description "A Person")
   (:direct-rules
    (:rule-1 (:dependants (last-name first-name) :volatile full-name)
@@ -60,6 +61,7 @@
   (:metaclass hyperobject-class)
   (:default-initargs :title nil :street nil) 
   (:user-name "Address")
+  (:user-name-plural "Addresses")
   (:default-print-slots title street)
   (:description "An address"))
 
@@ -70,6 +72,7 @@
                 :value-constraint stringp))
   (:metaclass hyperobject-class)
   (:user-name "Phone Number")
+  (:user-name-plural "Phone Numbers")
   (:default-initargs :title nil :phone-number nil)
   (:default-print-slots title phone-number)
   (:description "A phone number"))

diff --git a/metaclass.lisp b/metaclass.lisp
index a43df1f240a87c59660d941668685214cc4fa1e5..321a4b0f6eded131ab403ef05cfcf22203bab95d 100644 (file)
--- a/metaclass.lisp
+++ b/metaclass.lisp
@@ -8,10 +8,9 @@
 ;;;; Date Started:  Apr 2000
 ;;;;
 ;;;;
-;;;; $Id: metaclass.lisp,v 1.6 2002/12/14 02:30:58 kevin Exp $
-;;;;
-;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
+;;;; $Id: metaclass.lisp,v 1.7 2003/05/14 05:29:48 kevin Exp $
 ;;;;
+;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
  
 (in-package :hyperobject)

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)))

diff --git a/package.lisp b/package.lisp
index 8c61b3c50e443aac1676bbb3b4a7d00222edee3f..f23c72e7a6a739bd0eea4b750edd63c556993cb7 100644 (file)
--- a/package.lisp
+++ b/package.lisp
@@ -7,9 +7,9 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: package.lisp,v 1.45 2003/05/07 16:01:48 kevin Exp $
+;;;; $Id: package.lisp,v 1.46 2003/05/14 05:29:48 kevin Exp $
 ;;;;
-;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
+;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
 
 (eval-when (:compile-toplevel :execute)

diff --git a/rules.lisp b/rules.lisp
index a7bd048579fb5e8053d9d8083b1103da03f7d052..1c8f505dfdaa65787ea96cdfbced93a77b90b0ab 100644 (file)
--- a/rules.lisp
+++ b/rules.lisp
@@ -7,10 +7,9 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: rules.lisp,v 1.38 2003/05/04 03:30:28 kevin Exp $
-;;;;
-;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
+;;;; $Id: rules.lisp,v 1.39 2003/05/14 05:29:48 kevin Exp $
 ;;;;
+;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
  
 (in-package :hyperobject)

diff --git a/run-tests.lisp b/run-tests.lisp
index 5dca9f56823d79df8c7ff172b8d48491f1810d6f..d81d407e0f5e26d4853089e1773da5281d0eedf3 100644 (file)
--- a/run-tests.lisp
+++ b/run-tests.lisp
@@ -1,3 +1,17 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          run-tests.lisp
+;;;; Purpose:       Regression suite for hyperobject
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id: run-tests.lisp,v 1.2 2003/05/14 05:29:48 kevin Exp $
+;;;;
+;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
+;;;; *************************************************************************
+
 (defpackage #:run-tests (:use #:cl))
 (in-package #:run-tests)
 

diff --git a/sql.lisp b/sql.lisp
index e4faaa00ea3a61c2eefc8984bfc8f5e61f9391b9..2cbd602fc4a77c17290254c955b1b8dd1548a80a 100644 (file)
--- a/sql.lisp
+++ b/sql.lisp
@@ -7,10 +7,9 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: sql.lisp,v 1.4 2003/03/29 04:10:44 kevin Exp $
+;;;; $Id: sql.lisp,v 1.5 2003/05/14 05:29:48 kevin Exp $
 ;;;;
-;;;; This file, part of Hyperobject-SQL, is
-;;;;    Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
+;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
 
 (in-package :hyperobject)

diff --git a/tests.lisp b/tests.lisp
index 10f98bf6a747f3e2d024216439245b92d7e92916..d31ac172f9582751ef36aa489cefaa3c52076335 100644 (file)
--- a/tests.lisp
+++ b/tests.lisp
@@ -7,9 +7,9 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2003
 ;;;;
-;;;; $Id: tests.lisp,v 1.4 2003/04/29 09:47:10 kevin Exp $
+;;;; $Id: tests.lisp,v 1.5 2003/05/14 05:29:48 kevin Exp $
 ;;;;
-;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
+;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
 
 (defpackage #:hyperobject-tests
@@ -58,7 +58,7 @@
            :subobject t))
   (:metaclass hyperobject-class)
   (:default-initargs :title nil :street nil) 
-  (:user-name "Address")
+  (:user-name "Address" "Addresses")
   (:default-print-slots title street)
   (:description "An address"))
 
@@ -108,7 +108,7 @@
 
 (deftest p2 (view-to-string mary :subobjects t) " Person:
   Mary Jackson Thu, 4 May 2000 03:02:01 Style & Grace
-  Addresss:
+  Addresses:
     Home 321 Shady Lane
     Phone Numbers:
       Voice 367-9812

diff --git a/views.lisp b/views.lisp
index 2c2713e54079a34f850fac50dd68040ba18382ed..b5594a7a8cf71e8e004913f3b6509c7290f66c52 100644 (file)
--- a/views.lisp
+++ b/views.lisp
@@ -7,10 +7,9 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: views.lisp,v 1.35 2003/05/14 04:45:05 kevin Exp $
-;;;;
-;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
+;;;; $Id: views.lisp,v 1.36 2003/05/14 05:29:48 kevin Exp $
 ;;;;
+;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
  
 (in-package :hyperobject)
@@ -512,19 +511,28 @@
 
 (defvar +newline-string+ (format nil "~%"))
 
+(defun write-user-name-maybe-plural (obj nitems strm)
+  (write-string
+   (if (> nitems 1)
+       (hyperobject-class-user-name-plural obj)
+       (hyperobject-class-user-name obj))
+   strm))
+
 (defun initialize-text-view (view)
   (setf (list-start-str-or-func view)
        (compile nil
                 (eval '(lambda (obj nitems strm)
-                    (format strm "~a~P:~%"
-                            (hyperobject-class-user-name obj) nitems)))))
+                        (write-user-name-maybe-plural obj nitems strm)
+                        (write-char #\: strm)
+                        (write-char #\Newline strm)))))
   (setf (list-start-indent view) t)
   (setf (obj-data-indent view) t)
   (setf (obj-data-end-str view) +newline-string+))
 
 (defun html-list-start-func (obj nitems strm)
-  (format strm "<p><b>~a~p:</b></p><div class=\""
-         (hyperobject-class-user-name obj) nitems)
+  (write-string "<p><b>" strm)
+  (write-user-name-maybe-plural obj nitems strm)
+  (write-string ":</b></p><div class=\"" strm)
   (write-string (class-name-of obj) strm)
   (write-string "\"><ul>" strm)
   (write-char #\newline strm))
@@ -568,8 +576,9 @@
   (write-char #\< strm)
   (write-string (class-name-of x) strm)
   (write-string "list><title>" strm)
-  (format strm "~A~P:</title> ~%"
-         (hyperobject-class-user-name x) nitems))
+  (write-user-name-maybe-plural obj nitems strm)
+  (write-string ":</title>" strm)
+  (write-char #\newline strm))
 
 (defun initialize-xml-view (view)
   (initialize-text-view view)

diff --git a/wrapper.lisp b/wrapper.lisp
index e1c497c18894319b544a926abb6d02940857356f..d6f5427e0b00f3afab32701b00ec2e9f7e7c24b2 100644 (file)
--- a/wrapper.lisp
+++ b/wrapper.lisp
@@ -7,9 +7,9 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: wrapper.lisp,v 1.3 2002/12/13 07:33:54 kevin Exp $
+;;;; $Id: wrapper.lisp,v 1.4 2003/05/14 05:29:48 kevin Exp $
 ;;;;
-;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
+;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
 
 (in-package :hyperobject)