1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
|
;;;; -*- 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$
;;;;
;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
;;;; *************************************************************************
(defpackage #:hyperobject-tests
(:use #:hyperobject #:cl #:rtest #:kmrcl))
(in-package #:hyperobject-tests)
(defvar *now* (get-universal-time))
(defun get-now () *now*)
(defclass person (hyperobject)
((first-name :initarg :first-name :accessor first-name
:value-type (varchar 20)
:value-constraint stringp
:null-allowed nil)
(last-name :initarg :last-name :accessor last-name
:value-type (varchar 30)
:value-constraint stringp
:hyperlink find-person-by-last-name
:hyperlink-parameters (("narrow" . "yes"))
:null-allowed nil)
(full-name :value-type string :stored nil)
(dob :initarg :dob :accessor dob
:value-type integer
:print-formatter date-string
:value-constraint integerp
:input-filter convert-to-date)
(resume :initarg :resume :accessor resume
:value-type string
:value-constraint stringp)
;; (addresses :value-type (list-of subobject) :initarg :addresses :accessor addresses))
(addresses :initarg :addresses :accessor addresses
:subobject t)
(create-time :accessor create-time :compute-cached-value (get-now)))
(: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)))))
(defclass address (hyperobject)
((title :initarg :title :accessor title
:value-type (varchar 20)
:value-constraint stringp)
(street :initarg :street :accessor street
:value-type (varchar 30)
:value-constraint stringp)
(phones :initarg :phones :accessor phones
:subobject t)
(years-at-address :initarg :years-at-address :value-type fixnum
:accessor years-at-address
:value-constraint integerp))
(:metaclass hyperobject-class)
(:default-initargs :title nil :street nil)
(:user-name "Address" "Addresses")
(:default-print-slots title street years-at-address)
(:description "An address"))
(defclass phone (hyperobject)
((title :initarg :title :accessor title
:value-type (varchar 20)
:value-constraint stringp)
(phone-number :initarg :phone-number :accessor phone-number
:value-type (varchar 16)
:value-constraint stringp
:hyperlink search-phone-number))
(: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"
:years-at-address 10
:phones (list home-phone-1 home-phone-2)))
(defparameter office (make-instance 'address :title "Office" :street "113 Main St."
:years-at-address 5
:phones (list office-phone-1 office-phone-2 office-phone-3)))
(defparameter mary (make-instance 'person :first-name "Mary" :last-name "Jackson"
:dob (encode-universal-time
1 2 3 4 5 2000)
:addresses (list home office)
:resume "Style & Grace"))
(defun view-to-string (obj &rest args)
(with-output-to-string (strm)
(apply #'view obj :stream strm args)))
(rem-all-tests)
(deftest :p1 (view-to-string mary :vid :compact-text) "Person:
Mary Jackson Thu, 4 May 2000 03:02:01 Style & Grace
")
(deftest :p2 (view-to-string mary :subobjects t :vid :compact-text) "Person:
Mary Jackson Thu, 4 May 2000 03:02:01 Style & Grace
Addresses:
Home 321 Shady Lane 10
Phone Numbers:
Voice 367-9812
Fax 367-9813
Office 113 Main St. 5
Phone Numbers:
Main line 123-0001
Staff line 123-0002
Fax 123-0005
")
(deftest :p3 (view-to-string mary :vid :compact-text-labels)
"Person:
first-name Mary last-name Jackson dob Thu, 4 May 2000 03:02:01 resume Style & Grace
")
(deftest :p4 (view-to-string mary :vid :compact-text)
"Person:
Mary Jackson Thu, 4 May 2000 03:02:01 Style & Grace
")
(deftest :cv1 (years-at-address home)
10)
(deftest :cv2 (years-at-address office)
5)
(deftest :cv3 (equal (create-time mary) *now*)
t)
(deftest :s1 (slot-value (class-of mary) 'ho::user-name)
"Person")
(deftest :s2 (slot-value (class-of mary) 'ho::user-name-plural)
"Persons")
(deftest :s3 (slot-value (class-of home) 'ho::user-name-plural)
"Addresses")
(deftest :s4 (slot-value (class-of mary) 'ho::description)
"A Person")
|
