From 04f829aab1e5caaefe60391f756e7a5db2d1282b Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Wed, 14 May 2003 05:29:48 +0000 Subject: [PATCH] r4923: *** empty log message *** --- base-class.lisp | 4 ++-- connect.lisp | 5 ++-- examples/person.lisp | 5 +++- metaclass.lisp | 5 ++-- mop.lisp | 54 ++++++++++++++++++++++++++++---------------- package.lisp | 4 ++-- rules.lisp | 5 ++-- run-tests.lisp | 14 ++++++++++++ sql.lisp | 5 ++-- tests.lisp | 8 +++---- views.lisp | 27 ++++++++++++++-------- wrapper.lisp | 4 ++-- 12 files changed, 88 insertions(+), 52 deletions(-) diff --git a/base-class.lisp b/base-class.lisp index 417cbcc..4251cf1 100644 --- 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 d1b3789..05a8735 100644 --- 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 fe6cbe7..7216707 100644 --- 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 a43df1f..321a4b0 100644 --- 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 b34541c..204412d 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.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 8c61b3c..f23c72e 100644 --- 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 a7bd048..1c8f505 100644 --- 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 5dca9f5..d81d407 100644 --- 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 e4faaa0..2cbd602 100644 --- 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 10f98bf..d31ac17 100644 --- 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 2c2713e..b5594a7 100644 --- 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 "

~a~p:

" strm) + (write-user-name-maybe-plural obj nitems strm) + (write-string ":

    " strm) (write-char #\newline strm)) @@ -568,8 +576,9 @@ (write-char #\< strm) (write-string (class-name-of x) strm) (write-string "list>" strm) - (format strm "~A~P: ~%" - (hyperobject-class-user-name x) nitems)) + (write-user-name-maybe-plural obj nitems strm) + (write-string ":" strm) + (write-char #\newline strm)) (defun initialize-xml-view (view) (initialize-text-view view) diff --git a/wrapper.lisp b/wrapper.lisp index e1c497c..d6f5427 100644 --- 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) -- 2.34.1