From: Kevin M. Rosenberg Date: Thu, 22 May 2003 20:40:03 +0000 (+0000) Subject: r5024: *** empty log message *** X-Git-Tag: debian-2.11.0-2~64 X-Git-Url: http://git.kpe.io/?p=hyperobject.git;a=commitdiff_plain;h=0bb5498ce669d7f3c6d619bea10056b24db30b0a r5024: *** empty log message *** --- diff --git a/base-class.lisp b/base-class.lisp index 93eed69..4b65c8d 100644 --- a/base-class.lisp +++ b/base-class.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: base-class.lisp,v 1.8 2003/05/14 08:30:38 kevin Exp $ +;;;; $Id: base-class.lisp,v 1.9 2003/05/22 20:40:03 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -24,5 +24,6 @@ (defmethod print-object ((obj hyperobject) (s stream)) (print-unreadable-object (obj s :type t :identity nil) - (funcall (obj-data-func (get-category-view obj :compact-text)) obj s nil))) + (funcall (obj-data-printer (get-category-view obj :compact-text)) + obj s nil))) diff --git a/debian/changelog b/debian/changelog index 7d24471..1836e2a 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-hyperobject (2.8.5-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg Thu, 22 May 2003 14:23:26 -0600 + cl-hyperobject (2.8.4-1) unstable; urgency=low * New upstream diff --git a/hyperobject.asd b/hyperobject.asd index abc41a8..ff19326 100644 --- a/hyperobject.asd +++ b/hyperobject.asd @@ -7,7 +7,7 @@ ;;;; Author: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: hyperobject.asd,v 1.23 2003/04/28 21:11:55 kevin Exp $ +;;;; $Id: hyperobject.asd,v 1.24 2003/05/22 20:40:03 kevin Exp $ ;;;; ************************************************************************* (defpackage hyperobject-system (:use #:asdf #:cl)) @@ -30,7 +30,6 @@ (:file "sql" :depends-on ("connect")) (:file "views" :depends-on ("mop")) (:file "base-class" :depends-on ("views" "sql" "rules")) - (:file "wrapper" :depends-on ("base-class")) ) :depends-on (:kmrcl :clsql)) diff --git a/old/wrapper.lisp b/old/wrapper.lisp new file mode 100644 index 0000000..5c550af --- /dev/null +++ b/old/wrapper.lisp @@ -0,0 +1,66 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: wrapper.lisp +;;;; Purpose: Macro wrapper for Hyperobject +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id: wrapper.lisp,v 1.1 2003/05/22 20:40:03 kevin Exp $ +;;;; +;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg +;;;; ************************************************************************* + +(in-package :hyperobject) + +(eval-when (:compile-toplevel :execute) + (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))) + +#|| +(defmacro define-hyperobject (name parents fields &rest meta-fields) + (let* ((meta-fields (process-meta-fields fields meta-fields)) + (cl-fields (process-hyper-fields fields meta-fields))) + `(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (defclass ,name ,(append parents (list 'hyperobject)) ,cl-fields + ,@meta-fields))(and documentation (list (list :documentation documentation))))) + (let ((,value-func (compile nil (eval (slot-value ,meta 'value-func)))) + (,xml-value-func (compile nil (eval (slot-value ,meta 'xml-value-func))))) + (defmethod ho-title ((obj ,name)) + ,title) + (defmethod ho-name ((obj ,name)) + ,(string-downcase (symbol-name name))) + (defmethod ho-fields ((obj ,name)) + ',(slot-value meta 'fields)) + (defmethod ho-references ((obj ,name)) + ',(slot-value meta 'references)) + (defmethod ho-subobjects ((obj ,name)) + ',(slot-value meta 'subobjects)) + (defmethod ho-value-func ((obj ,name)) + ,value-func) + (defmethod ho-xml-value-func ((obj ,name)) + ,xml-value-func) + (defmethod ho-fmtstr-text ((obj ,name)) + ,(slot-value meta 'fmtstr-text)) + (defmethod ho-fmtstr-html ((obj ,name)) + ,(slot-value meta 'fmtstr-html)) + (defmethod ho-fmtstr-xml ((obj ,name)) + ,(slot-value meta 'fmtstr-xml)) + (defmethod ho-fmtstr-text-labels ((obj ,name)) + ,(slot-value meta 'fmtstr-text-labels)) + (defmethod ho-fmtstr-html-labels ((obj ,name)) + ,(slot-value meta 'fmtstr-html-labels)) + (defmethod ho-fmtstr-xml-labels ((obj ,name)) + ,(slot-value meta 'fmtstr-xml-labels)) + (defmethod ho-fmtstr-html-ref ((obj ,name)) + ,(slot-value meta 'fmtstr-html-ref)) + (defmethod ho-fmtstr-xml-ref ((obj ,name)) + ,(slot-value meta 'fmtstr-xml-ref)) + (defmethod ho-fmtstr-html-ref-labels ((obj ,name)) + ,(slot-value meta 'fmtstr-html-ref-labels)) + (defmethod ho-fmtstr-xml-ref-labels ((obj ,name)) + ,(slot-value meta 'fmtstr-xml-ref-labels)) + )))) + +||# diff --git a/views.lisp b/views.lisp index 6c7b9fa..70819fd 100644 --- a/views.lisp +++ b/views.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: views.lisp,v 1.45 2003/05/16 07:35:09 kevin Exp $ +;;;; $Id: views.lisp,v 1.46 2003/05/22 20:40:03 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -40,29 +40,29 @@ :accessor file-start-str) (file-end-str :type (or string null) :initform nil :initarg :file-end-str :accessor file-end-str) - (list-start-str-or-func :type (or string function null) :initform nil - :initarg :list-start-str-or-func - :accessor list-start-str-or-func) + (list-start-printer :type (or string function null) :initform nil + :initarg :list-start-printer + :accessor list-start-printer) (list-start-indent :initform nil :initarg :list-start-indent :accessor list-start-indent) - (list-end-str-or-func :type (or string function null) :initform nil - :initarg :list-end-str-or-func - :accessor list-end-str-or-func) + (list-end-printer :type (or string function null) :initform nil + :initarg :list-end-printer + :accessor list-end-printer) (list-end-indent :initform nil :initarg :list-end-indent :accessor list-end-indent) - (obj-start-str-or-func :type (or string function null) :initform nil :initarg :obj-start-str-or-func - :accessor obj-start-str-or-func) + (obj-start-printer :type (or string function null) :initform nil :initarg :obj-start-printer + :accessor obj-start-printer) (obj-start-indent :initform nil :initarg :obj-start-indent :accessor obj-start-indent) - (obj-end-str-or-func :type (or string function null) :initform nil :initarg :obj-end-str-or-func - :accessor obj-end-str-or-func) + (obj-end-printer :type (or string function null) :initform nil :initarg :obj-end-printer + :accessor obj-end-printer) (obj-end-indent :initform nil :initarg :obj-end-indent :accessor obj-end-indent) (obj-data-indent :initform nil :initarg :obj-data-indent :accessor obj-data-indent) - (obj-data-func :type (or function null) :initform nil - :initarg :obj-data-func - :accessor obj-data-func) + (obj-data-printer :type (or function null) :initform nil + :initarg :obj-data-printer + :accessor obj-data-printer) (obj-data-print-code :type (or function null) :initform nil :initarg :obj-data-print-code :accessor obj-data-print-code) @@ -335,7 +335,7 @@ (setf (obj-data-print-code view) `(lambda (x s links) (declare (ignorable links)) ,@(map 'list #'identity print-func))) - (setf (obj-data-func view) + (setf (obj-data-printer view) (compile nil (eval (obj-data-print-code view))))) (setf (link-slots view) (nreverse links))) @@ -391,7 +391,7 @@ strm)) (defun initialize-text-view (view) - (setf (list-start-str-or-func view) + (setf (list-start-printer view) (compile nil (eval '(lambda (obj nitems strm) (write-user-name-maybe-plural obj nitems strm) @@ -414,13 +414,13 @@ (setf (file-start-str view) (format nil "~%")) (setf (file-end-str view) (format nil "~%")) (setf (list-start-indent view) t) - (setf (list-start-str-or-func view) #'html-list-start-func) - (setf (list-end-str-or-func view) (format nil "~%")) + (setf (list-start-printer view) #'html-list-start-func) + (setf (list-end-printer view) (format nil "~%")) (setf (list-end-indent view) t) (setf (obj-start-indent view) t) - (setf (obj-start-str-or-func view) "
  • ") + (setf (obj-start-printer view) "
  • ") (setf (obj-end-indent view) t) - (setf (obj-end-str-or-func view) (format nil "
    • ~%")) + (setf (obj-end-printer view) (format nil "~%")) (setf (obj-data-indent view) nil)) (defun initialize-xhtml-view (view) @@ -428,13 +428,13 @@ (setf (file-start-str view) (format nil "~%")) (setf (file-end-str view) (format nil "~%")) (setf (list-start-indent view) t) - (setf (list-start-str-or-func view) #'html-list-start-func) - (setf (list-end-str-or-func view) (format nil "~%")) + (setf (list-start-printer view) #'html-list-start-func) + (setf (list-end-printer view) (format nil "~%")) (setf (list-end-indent view) t) (setf (obj-start-indent view) t) - (setf (obj-start-str-or-func view) "
  • ") + (setf (obj-start-printer view) "
  • ") (setf (obj-end-indent view) t) - (setf (obj-end-str-or-func view) (format nil "
    • ~%")) + (setf (obj-end-printer view) (format nil "~%")) (setf (obj-data-indent view) nil)) (defun xmlformat-list-end-func (x strm) @@ -456,12 +456,12 @@ (initialize-text-view view) (setf (file-start-str view) "") ; (std-xml-header) (setf (list-start-indent view) t) - (setf (list-start-str-or-func view) #'xmlformat-list-start-func) + (setf (list-start-printer view) #'xmlformat-list-start-func) (setf (list-end-indent view) t) - (setf (list-end-str-or-func view) #'xmlformat-list-end-func) - (setf (obj-start-str-or-func view) (format nil "<~(~a~)>" (object-class-name view))) + (setf (list-end-printer view) #'xmlformat-list-end-func) + (setf (obj-start-printer view) (format nil "<~(~a~)>" (object-class-name view))) (setf (obj-start-indent view) t) - (setf (obj-end-str-or-func view) (format nil "~%" (object-class-name view))) + (setf (obj-end-printer view) (format nil "~%" (object-class-name view))) (setf (obj-end-indent view) nil) (setf (obj-data-indent view) nil)) @@ -481,7 +481,7 @@ (defun fmt-list-start (obj view strm indent num-items) (when (list-start-indent view) (indent-spaces indent strm)) - (awhen (list-start-str-or-func view) + (awhen (list-start-printer view) (if (stringp it) (write-string it strm) (funcall it obj num-items strm)))) @@ -490,7 +490,7 @@ (declare (ignore num-items)) (when (list-end-indent view) (indent-spaces indent strm)) - (awhen (list-end-str-or-func view) + (awhen (list-end-printer view) (if (stringp it) (write-string it strm) (funcall it obj strm)))) @@ -500,7 +500,7 @@ (defun fmt-obj-start (obj view strm indent) (when (obj-start-indent view) (indent-spaces indent strm)) - (awhen (obj-start-str-or-func view) + (awhen (obj-start-printer view) (if (stringp it) (write-string it strm) (funcall it obj strm)))) @@ -508,7 +508,7 @@ (defun fmt-obj-end (obj view strm indent) (when (obj-end-indent view) (indent-spaces indent strm)) - (awhen (obj-end-str-or-func view) + (awhen (obj-end-printer view) (if (stringp it) (write-string it strm) (funcall it obj strm)))) @@ -547,7 +547,7 @@ (write-string it strm))) (defun fmt-obj-data-plain (obj view strm) - (awhen (obj-data-func view) + (awhen (obj-data-printer view) (funcall it obj strm nil))) (defun fmt-obj-data-with-link (obj view strm refvars) @@ -559,7 +559,7 @@ (append (link-parameters it) refvars)) refvalues) (push (make-link-end obj view name) refvalues))) - (funcall (obj-data-func view) obj strm (nreverse refvalues)))) + (funcall (obj-data-printer view) obj strm (nreverse refvalues)))) (defun obj-data (obj view) "Returns the objects data as a string. Used by common-graphics outline function" diff --git a/wrapper.lisp b/wrapper.lisp deleted file mode 100644 index d6f5427..0000000 --- a/wrapper.lisp +++ /dev/null @@ -1,66 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: wrapper.lisp -;;;; Purpose: Macro wrapper for Hyperobject -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Apr 2000 -;;;; -;;;; $Id: wrapper.lisp,v 1.4 2003/05/14 05:29:48 kevin Exp $ -;;;; -;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg -;;;; ************************************************************************* - -(in-package :hyperobject) - -(eval-when (:compile-toplevel :execute) - (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))) - -#|| -(defmacro define-hyperobject (name parents fields &rest meta-fields) - (let* ((meta-fields (process-meta-fields fields meta-fields)) - (cl-fields (process-hyper-fields fields meta-fields))) - `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (defclass ,name ,(append parents (list 'hyperobject)) ,cl-fields - ,@meta-fields))(and documentation (list (list :documentation documentation))))) - (let ((,value-func (compile nil (eval (slot-value ,meta 'value-func)))) - (,xml-value-func (compile nil (eval (slot-value ,meta 'xml-value-func))))) - (defmethod ho-title ((obj ,name)) - ,title) - (defmethod ho-name ((obj ,name)) - ,(string-downcase (symbol-name name))) - (defmethod ho-fields ((obj ,name)) - ',(slot-value meta 'fields)) - (defmethod ho-references ((obj ,name)) - ',(slot-value meta 'references)) - (defmethod ho-subobjects ((obj ,name)) - ',(slot-value meta 'subobjects)) - (defmethod ho-value-func ((obj ,name)) - ,value-func) - (defmethod ho-xml-value-func ((obj ,name)) - ,xml-value-func) - (defmethod ho-fmtstr-text ((obj ,name)) - ,(slot-value meta 'fmtstr-text)) - (defmethod ho-fmtstr-html ((obj ,name)) - ,(slot-value meta 'fmtstr-html)) - (defmethod ho-fmtstr-xml ((obj ,name)) - ,(slot-value meta 'fmtstr-xml)) - (defmethod ho-fmtstr-text-labels ((obj ,name)) - ,(slot-value meta 'fmtstr-text-labels)) - (defmethod ho-fmtstr-html-labels ((obj ,name)) - ,(slot-value meta 'fmtstr-html-labels)) - (defmethod ho-fmtstr-xml-labels ((obj ,name)) - ,(slot-value meta 'fmtstr-xml-labels)) - (defmethod ho-fmtstr-html-ref ((obj ,name)) - ,(slot-value meta 'fmtstr-html-ref)) - (defmethod ho-fmtstr-xml-ref ((obj ,name)) - ,(slot-value meta 'fmtstr-xml-ref)) - (defmethod ho-fmtstr-html-ref-labels ((obj ,name)) - ,(slot-value meta 'fmtstr-html-ref-labels)) - (defmethod ho-fmtstr-xml-ref-labels ((obj ,name)) - ,(slot-value meta 'fmtstr-xml-ref-labels)) - )))) - -||#