From: Kevin M. Rosenberg Date: Mon, 28 Apr 2003 19:06:30 +0000 (+0000) Subject: r4664: *** empty log message *** X-Git-Tag: debian-2.11.0-2~102 X-Git-Url: http://git.kpe.io/?p=hyperobject.git;a=commitdiff_plain;h=7b3ca1025e0b572b6511c044e948aeab2147af45 r4664: *** empty log message *** --- diff --git a/debian/changelog b/debian/changelog index 8267f8a..a1c0602 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,10 @@ +cl-hyperobject (2.7.0-1) unstable; urgency=low + + * Add regression testing + * Depend on cl-rt package + + -- Kevin M. Rosenberg Mon, 28 Apr 2003 11:40:27 -0600 + cl-hyperobject (2.6.5-1) unstable; urgency=low * New upstream diff --git a/debian/control b/debian/control index 74167b0..da544d6 100644 --- a/debian/control +++ b/debian/control @@ -7,7 +7,7 @@ Standards-Version: 3.5.9.0 Package: cl-hyperobject Architecture: all -Depends: ${shlibs:Depends}, common-lisp-controller, cl-kmrcl +Depends: ${shlibs:Depends}, common-lisp-controller, cl-kmrcl, cl-rt Description: Common Lisp library for hyperobjects This package contains a library for creating and display hyperobjects. Hyperobjects contain references to subobjects as well as to linked diff --git a/debian/rules b/debian/rules index 80d3568..bb89106 100755 --- a/debian/rules +++ b/debian/rules @@ -2,16 +2,19 @@ export DH_COMPAT=4 -pkg := hyperobject -debpkg := cl-hyperobject +pkg := hyperobject +pkg-tests := $(pkg)-tests +debpkg := cl-$(pkg) clc-source := usr/share/common-lisp/source clc-systems := usr/share/common-lisp/systems -clc-hyperobject := $(clc-source)/$(pkg) - +clc-files := $(clc-source)/$(pkg) +clc-tests := $(clc-source)/$(pkg-tests) doc-dir := usr/share/doc/$(debpkg) +tests-files := tests.lisp +source-files := $(filter-out $(tests-files),$(wildcard *.lisp)) configure: configure-stamp configure-stamp: @@ -41,9 +44,11 @@ install: build dh_testroot dh_clean -k # Add here commands to install the package into debian/hyperobject. - dh_installdirs $(clc-systems) $(clc-hyperobject) $(doc-dir) - dh_install hyperobject.asd $(wildcard *.lisp) $(clc-hyperobject) - dh_link $(clc-hyperobject)/hyperobject.asd $(clc-systems)/hyperobject.asd + dh_installdirs $(clc-systems) $(clc-files) $(doc-dir) $(clc-tests) + dh_install $(pkg).asd $(source-files) $(clc-files) + dh_link $(clc-files)/$(pkg).asd $(clc-systems)/$(pkg).asd + dh_install $(pkg-tests).asd $(tests-files) $(clc-tests) + dh_link $(clc-tests)/$(pkg-tests).asd $(clc-systems)/$(pkg-tests).asd # Build architecture-independent files here. binary-indep: build install @@ -51,7 +56,7 @@ binary-indep: build install dh_testroot -i # dh_installdebconf dh_installdocs -i - dh_installexamples -i $(wilcard examples/example*.lisp) + dh_installexamples -i $(wilcard examples/*.lisp) # dh_installmenu # dh_installlogrotate # dh_installemacsen diff --git a/hyperobject-tests.asd b/hyperobject-tests.asd new file mode 100644 index 0000000..33b73b1 --- /dev/null +++ b/hyperobject-tests.asd @@ -0,0 +1,25 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: hyperobject-tests.asd +;;;; Purpose: ASDF system definitionf for hyperobject testing package +;;;; Author: Kevin M. Rosenberg +;;;; Date Started: Apr 2003 +;;;; +;;;; $Id: hyperobject-tests.asd,v 1.1 2003/04/28 19:06:30 kevin Exp $ +;;;; ************************************************************************* + +(defpackage #:hyperobject-tests-system + (:use #:asdf #:cl)) +(in-package #:hyperobject-tests-system) + +(defsystem hyperobject-tests + :depends-on (:rt :hyperobject) + :components ((:file "tests"))) + +(defmethod perform ((o test-op) (c (eql (find-system :hyperobject-tests)))) + (or (funcall (intern (symbol-name '#:do-tests) + (find-package '#:regression-test))) + (error "test-op failed"))) + diff --git a/hyperobject.asd b/hyperobject.asd index 3c47f16..4ba98e7 100644 --- a/hyperobject.asd +++ b/hyperobject.asd @@ -4,21 +4,21 @@ ;;;; ;;;; Name: hyperobject.asd ;;;; Purpose: ASDF system definition for hyperobject package -;;;; Programmer: Kevin M. Rosenberg +;;;; Author: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $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 +;;;; $Id: hyperobject.asd,v 1.22 2003/04/28 19:06:13 kevin Exp $ ;;;; ************************************************************************* -(in-package :asdf) +(defpackage hyperobject-system + (:use #:asdf #:cl)) +(in-package :hyperobject-system) #+(or allegro lispworks sbcl cmu scl) (defsystem hyperobject - :name "cl-hyperobject" + :name "hyperobject" :author "Kevin M. Rosenberg " - :version "2.6.x" + :version "2.7.x" :maintainer "Kevin M. Rosenberg " :licence "BSD-like License" @@ -35,15 +35,9 @@ ) :depends-on (:kmrcl :clsql)) +#+(or allegro lispworks sbcl cmu scl) (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/mop.lisp b/mop.lisp index 9925c0f..a8d5f6f 100644 --- a/mop.lisp +++ b/mop.lisp @@ -11,7 +11,7 @@ ;;;; in Text, HTML, and XML formats. This includes hyperlinking ;;;; capability and sub-objects. ;;;; -;;;; $Id: mop.lisp,v 1.63 2003/04/25 05:00:58 kevin Exp $ +;;;; $Id: mop.lisp,v 1.64 2003/04/28 19:06:13 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -72,7 +72,7 @@ (defclass subobject () ((name-class :type symbol :initform nil :initarg :name-class :reader name-class) (name-slot :type symbol :initform nil :initarg :name-slot :reader name-slot) - (lookup :type symbol :initform nil :initarg :lookup :reader lookup) + (lookup :type (or function symbol) :initform nil :initarg :lookup :reader lookup) (lookup-keys :type list :initform nil :initarg :lookup-keys :reader lookup-keys)) (:documentation "Contains subobject information")) @@ -86,8 +86,8 @@ ((name :type symbol :initform nil :initarg :name :reader name) (lookup ;; The type specifier seems to break sbcl - ;; :type (or function symbol) - :type t + :type (or function symbol) + ;; :type t :initform nil :initarg :lookup :reader lookup) (link-parameters :type list :initform nil :initarg :link-parameters :reader link-parameters))) @@ -336,29 +336,31 @@ (setf (subobjects cl) (let ((subobjects '())) (dolist (slot (class-slots cl)) - (let-when (subobj-def (esd-subobject slot)) - (let ((subobject (make-instance 'subobject - :name-class (class-name cl) - :name-slot (slot-definition-name slot) - :lookup (if (atom subobj-def) - subobj-def - (car subobj-def)) - :lookup-keys (if (atom subobj-def) - nil - (cdr subobj-def))))) - (unless (eq (lookup subobject) t) - #-(or sbcl cmu lispworks) - (eval - `(hyperobject::def-lazy-reader ,(name-class subobject) - ,(name-slot subobject) ,(lookup subobject) - ,@(lookup-keys subobject))) - #+(or sbcl cmu lispworks) - (apply #'ensure-lazy-reader - (name-class subobject) (name-slot subobject) (lookup subobject) (lookup-keys subobject)) - ) - (push subobject subobjects)))) + (let-when + (subobj-def (esd-subobject slot)) + (let ((subobject + (make-instance 'subobject + :name-class (class-name cl) + :name-slot (slot-definition-name slot) + :lookup (if (atom subobj-def) + subobj-def + (car subobj-def)) + :lookup-keys (if (atom subobj-def) + nil + (cdr subobj-def))))) + (unless (eq (lookup subobject) t) + #-(or sbcl cmu lispworks) + (eval + `(hyperobject::def-lazy-reader ,(name-class subobject) + ,(name-slot subobject) ,(lookup subobject) + ,@(lookup-keys subobject))) + #+(or sbcl cmu lispworks) + (apply #'ensure-lazy-reader + (name-class subobject) (name-slot subobject) + (lookup subobject) (lookup-keys subobject))) + (push subobject subobjects)))) ;; sbcl/cmu reverse class-slots compared to the defclass form - ;; subobject is already reversed from the dolist/push loop, so re-reverse on cmu/sbcl + ;; so re-reverse on cmu/sbcl #+(or cmu sbcl) subobjects #-(or cmu sbcl) (nreverse subobjects) ))) diff --git a/tests.lisp b/tests.lisp index c7dbfa4..1354996 100644 --- a/tests.lisp +++ b/tests.lisp @@ -7,27 +7,50 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2003 ;;;; -;;;; $Id: tests.lisp,v 1.1 2003/04/28 16:03:57 kevin Exp $ +;;;; $Id: tests.lisp,v 1.2 2003/04/28 19:06:13 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; ;;;; ************************************************************************* - -(in-package :hyperobject-user) + +(defpackage #:hyperobject-tests + (:use #:hyperobject #:cl #:rtest)) +(in-package #:hyperobject-tests) + +(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 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 + ((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 :null-allowed nil) + :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 + (dob :initarg :dob :accessor dob + :value-type integer + :print-formatter format-date + :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 :subobject t :initarg :addresses :accessor addresses)) + ;; (addresses :value-type (list-of subobject) :initarg :addresses :accessor addresses)) + (addresses :initarg :addresses :accessor addresses + :subobject t)) (:metaclass hyperobject-class) (:default-initargs :first-name "" :last-name "" :dob 0 :resume nil) (:default-print-slots first-name last-name dob resume) @@ -35,26 +58,17 @@ (: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)))) + (setf full-name (concatenate 'string first-name " " last-name))))) (defclass address (hyperobject) - ((title :value-type (varchar 20) :initarg :title :accessor title - :value-constraint stringp) - (street :value-type (varchar 30) :initarg :street :accessor street + ((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 :subobject t :initarg :phones :accessor phones)) + (phones :initarg :phones :accessor phones + :subobject t)) (:metaclass hyperobject-class) (:default-initargs :title nil :street nil) (:user-name "Address") @@ -62,9 +76,11 @@ (:description "An address")) (defclass phone (hyperobject) - ((title :value-type (varchar 20) :initarg :title :accessor title + ((title :initarg :title :accessor title + :value-type (varchar 20) :value-constraint stringp) - (phone-number :value-type (varchar 16) :initarg :phone-number :accessor phone-number + (phone-number :initarg :phone-number :accessor phone-number + :value-type (varchar 16) :value-constraint stringp)) (:metaclass hyperobject-class) (:user-name "Phone Number") @@ -72,7 +88,6 @@ (: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")) @@ -88,13 +103,37 @@ (defparameter mary (make-instance 'person :first-name "Mary" :last-name "Jackson" - :dob (get-universal-time) + :dob (encode-universal-time + 1 2 3 4 5 2000) :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) + +(defun view-to-string (obj &rest args) + (with-output-to-string (strm) + (apply #'view obj :stream strm args))) + +(rem-all-tests) -(format t "~&Text Format~%") -(view mary :subobjects t) +(deftest p1 (view-to-string mary) " Person: + Mary Jackson Thu, 4 May 2000 03:02:01 Style & Grace +") -(format t "~&XML Format with field labels and hyperlinks~%") -(view mary :subobjects t :category :xml-link-labels) +(deftest p2 (view-to-string mary :subobjects t) " Person: + Mary Jackson Thu, 4 May 2000 03:02:01 Style & Grace + Addresss: + Home 321 Shady Lane + Phone Numbers: + Voice 367-9812 + Fax 367-9813 + Office 113 Main St. + Phone Numbers: + Main line 123-0001 + Staff line 123-0002 + Fax 123-0005 +")