From: Kevin M. Rosenberg <kevin@rosenberg.net>
Date: Mon, 28 Apr 2003 16:07:43 +0000 (+0000)
Subject: r4659: *** empty log message ***
X-Git-Tag: debian-2.11.0-2~103
X-Git-Url: http://git.kpe.io/?p=hyperobject.git;a=commitdiff_plain;h=f45b5a177039ec999d3fd43ddf2f7bad8e8e4fd3

r4659: *** empty log message ***
---

diff --git a/hyperobject.asd b/hyperobject.asd
index 91d2d2b..3c47f16 100644
--- a/hyperobject.asd
+++ b/hyperobject.asd
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: hyperobject.asd,v 1.20 2003/04/25 04:53:52 kevin Exp $
+;;;; $Id: hyperobject.asd,v 1.21 2003/04/28 16:07:11 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -15,7 +15,7 @@
 (in-package :asdf)
 
 #+(or allegro lispworks sbcl cmu scl)
-(defsystem :hyperobject 
+(defsystem hyperobject 
   :name "cl-hyperobject"
   :author "Kevin M. Rosenberg <kevin@rosenberg.net>"
   :version "2.6.x"
@@ -35,4 +35,15 @@
    )
   :depends-on (:kmrcl :clsql))
 
+(defmethod perform ((o test-op) (c (eql (find-system :hyperobject))))
+  (oos 'load-op 'hyperobject-tests)
+  (oos 'test-op 'hyperobject-tests))
 
+(defsystem hyperobject-tests
+    :depends-on (rt)
+    :components ((:file "tests")))
+
+(defmethod perform ((o test-op) (c (eql (find-system :sb-aclrepl-tests))))
+  (or (funcall (intern (symbol-name '#:do-tests)
+		       (find-package '#:sb)))
+      (error "test-op failed")))
diff --git a/tests.lisp b/tests.lisp
new file mode 100644
index 0000000..c7dbfa4
--- /dev/null
+++ b/tests.lisp
@@ -0,0 +1,100 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          hyperobject-tests.lisp
+;;;; Purpose:       Hyperobject tests file
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2003
+;;;;
+;;;; $Id: tests.lisp,v 1.1 2003/04/28 16:03:57 kevin Exp $
+;;;;
+;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+ 
+(in-package :hyperobject-user)
+
+(defclass person (hyperobject)
+  ((first-name :value-type (varchar 20) :initarg :first-name :accessor first-name
+	       :value-constraint stringp :null-allowed nil)
+   (last-name :value-type (varchar 30) :initarg :last-name :accessor last-name
+	      :value-constraint stringp
+	      :hyperlink find-person-by-last-name :null-allowed nil)
+   (full-name :value-type string :stored nil)
+   (dob :value-type integer :initarg :dob :accessor dob :print-formatter format-date
+	:value-constraint integerp :input-filter convert-to-date)
+   (resume :value-type string :initarg :resume :accessor resume
+	   :value-constraint stringp)
+;;   (addresses :value-type (list-of subobject) :initarg :addresses :accessor addresses))
+   (addresses :subobject t :initarg :addresses :accessor addresses))
+  (:metaclass hyperobject-class)
+  (:default-initargs :first-name "" :last-name "" :dob 0 :resume nil) 
+  (:default-print-slots first-name last-name dob resume)
+  (:user-name "Person")
+  (:description "A Person")
+  (:direct-rules
+   (:rule-1 (:dependants (last-name first-name) :volatile full-name)
+	      (setf full-name (concatenate 'string first-name " " last-name)))))
+
+(defun format-date (ut)
+  (when (typep ut 'integer)
+      (multiple-value-bind (sec min hr day mon year dow daylight-p zone)
+	  (decode-universal-time ut)
+	(declare (ignore daylight-p zone))
+	(format nil "~[Mon~;Tue~;Wed~;Thu~;Fri~;Sat~;Sun~], ~d ~[Jan~;Feb~;Mar~;Apr~;May~;Jun~;Jul~;Aug~;Sep~;Oct~;Nov~;Dec~] ~d ~2,'0d:~2,'0d:~2,'0d" 
+		dow
+		day
+		(1- mon)
+		year
+		hr min sec))))
+
+(defclass address (hyperobject)
+  ((title :value-type (varchar 20) :initarg :title :accessor title
+	  :value-constraint stringp)
+   (street :value-type (varchar 30) :initarg :street :accessor street
+	   :value-constraint stringp)
+   (phones :subobject t :initarg :phones :accessor phones))
+  (:metaclass hyperobject-class)
+  (:default-initargs :title nil :street nil) 
+  (:user-name "Address")
+  (:default-print-slots title street)
+  (:description "An address"))
+
+(defclass phone (hyperobject)
+  ((title :value-type (varchar 20) :initarg :title :accessor title
+	  :value-constraint stringp)
+   (phone-number :value-type (varchar 16) :initarg :phone-number :accessor phone-number
+		 :value-constraint stringp))
+  (:metaclass hyperobject-class)
+  (:user-name "Phone Number")
+  (:default-initargs :title nil :phone-number nil)
+  (:default-print-slots title phone-number)
+  (:description "A phone number"))
+
+
+(defparameter home-phone-1 (make-instance 'phone :title "Voice" :phone-number "367-9812"))
+(defparameter home-phone-2 (make-instance 'phone :title "Fax" :phone-number "367-9813"))
+
+(defparameter office-phone-1 (make-instance 'phone :title "Main line" :phone-number "123-0001"))
+(defparameter office-phone-2 (make-instance 'phone :title "Staff line" :phone-number "123-0002"))
+(defparameter office-phone-3 (make-instance 'phone :title "Fax" :phone-number "123-0005"))
+
+(defparameter home (make-instance 'address :title "Home" :street "321 Shady Lane"
+				  :phones (list home-phone-1 home-phone-2)))
+
+(defparameter office (make-instance 'address :title "Office" :street "113 Main St."
+				    :phones (list office-phone-1 office-phone-2 office-phone-3)))
+
+			      
+(defparameter mary (make-instance 'person :first-name "Mary" :last-name "Jackson"
+			    :dob (get-universal-time)
+			    :addresses (list home office)
+			    :resume "Style & Grace"))
+
+
+(format t "~&Text Format~%")
+(view mary :subobjects t)
+
+(format t "~&XML Format with field labels and hyperlinks~%")
+(view mary :subobjects t :category :xml-link-labels)