/usr/share/common-lisp/source/hyperobject-tests/tests.lisp is in cl-hyperobject 2.12.0-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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")
|