From: Kevin M. Rosenberg Date: Fri, 22 Nov 2002 15:45:59 +0000 (+0000) Subject: r3454: *** empty log message *** X-Git-Tag: debian-2.11.0-2~270 X-Git-Url: http://git.kpe.io/?p=hyperobject.git;a=commitdiff_plain;h=7ffe31bff2d7daa3df28ed34fe439f7e541ffbb5 r3454: *** empty log message *** --- diff --git a/debian/changelog b/debian/changelog index 4238430..f25974c 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-hyperobject (2.0.0-1) unstable; urgency=low + + * New version + + -- Kevin M. Rosenberg Fri, 22 Nov 2002 08:40:39 -0700 + cl-hyperobject (1.2.4-1) unstable; urgency=low * Remove 'load-compiled-op from .asd file diff --git a/debian/control b/debian/control index 5fc7d3b..2b086ff 100644 --- a/debian/control +++ b/debian/control @@ -3,7 +3,7 @@ Section: devel Priority: optional Maintainer: Kevin M. Rosenberg Build-Depends-Indep: debhelper (>= 4.0.0) -Standards-Version: 3.5.7.1 +Standards-Version: 3.5.8.0 Package: cl-hyperobject Architecture: all diff --git a/debian/rules b/debian/rules index 8eeb8e4..c954bf3 100755 --- a/debian/rules +++ b/debian/rules @@ -42,7 +42,7 @@ install: build 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 $(shell echo *.lisp) $(clc-hyperobject) + dh_install hyperobject.asd hyperobject.lisp hyperobject-no-mop.lisp $(clc-hyperobject) dh_link $(clc-hyperobject)/hyperobject.asd $(clc-systems)/hyperobject.asd # Build architecture-independent files here. @@ -51,7 +51,7 @@ binary-indep: build install dh_testroot -i # dh_installdebconf dh_installdocs -i - dh_installexamples -i hyperobject-example.lisp + dh_installexamples -i example.lisp no-mop-example.lisp # dh_installmenu # dh_installlogrotate # dh_installemacsen diff --git a/example.lisp b/example.lisp index 974a1e2..9398cc6 100644 --- a/example.lisp +++ b/example.lisp @@ -2,31 +2,31 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: hyperobject-plain-example.lisp -;;;; Purpose: Hyper Object Metaclass +;;;; Name: hyperobject-example.lisp +;;;; Purpose: Hyperobject Example file ;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Apr 2000 +;;;; Date Started: Oct 2002 ;;;; -;;;; This metaclass as functions to classes to allow display -;;;; in Text, HTML, and XML formats. This includes hyperlinking -;;;; capability and sub-objects. +;;;; A simple example file for hyperobjects ;;;; -;;;; $Id: example.lisp,v 1.1 2002/11/22 10:49:24 kevin Exp $ +;;;; $Id: example.lisp,v 1.2 2002/11/22 15:45:06 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; ;;;; ************************************************************************* -(in-package :hyperobject-user) +(in-package :hyperobject-mop-user) -(define-hyperobject person () - ((first-name :type string :reference find-person-by-last-name) - (last-name :type string) - (dob :type integer :initform 0 :format-func format-date) - (resume :type cdata) - (addresses :subobject t)) - (:title "Person") - (:documentation "Person hyperobject class")) + +(defclass person (hyperobject) + ((first-name :type string :initarg :first-name :reader first-name :initform nil) + (last-name :type string :initarg :last-name :reader last-name :initform nil + :reference find-person-by-last-name) + (dob :type integer :initarg :dob :reader dob :initform 0 :format-func format-date) + (resume :type cdata :initarg :resume :reader resume) + (addresses :initarg :addresses :reader addresses :initform nil :subobject t)) + (:metaclass hyperobject-class) + (:title "Person")) (defun format-date (ut) (when (typep ut 'integer) @@ -40,17 +40,17 @@ year hr min sec)))) -(define-hyperobject address () - ((title :type string) - (street :type string) - (phones :subobject t)) - (:title "Address") - (:documentation "Address hyperobject")) +(defclass address (hyperobject) + ((title :type string :initarg :title :reader title :initform nil) + (street :type string :initarg :street :reader street :initform nil) + (phones :initarg :phones :reader phones :initform nil :subobject t)) + (:metaclass hyperobject-class) + (:title "Address")) -(define-hyperobject phone () - ((phone-number :type string)) - (:title "Phone Number") - (:documentation "Phone hyperobject")) +(defclass phone (hyperobject) + ((phone-number :type string :initarg :phone-number :reader phone-number)) + (:metaclass hyperobject-class) + (:title "Phone Number")) (defparameter home-phone-1 (make-instance 'phone :phone-number "367-9812")) diff --git a/hyperobject-mop.lisp b/hyperobject-mop.lisp deleted file mode 100644 index 9f3113a..0000000 --- a/hyperobject-mop.lisp +++ /dev/null @@ -1,874 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: hyperobject.lisp -;;;; Purpose: Hyper Object Metaclass -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Apr 2000 -;;;; -;;;; This metaclass as functions to classes to allow display -;;;; in Text, HTML, and XML formats. This includes hyperlinking -;;;; capability and sub-objects. -;;;; -;;;; $Id: hyperobject-mop.lisp,v 1.3 2002/11/22 14:58:16 kevin Exp $ -;;;; -;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg -;;;; -;;;; ************************************************************************* - -(in-package :hyperobject-mop) - - -(eval-when (:compile-toplevel :execute) - (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))) - - -;; Utilities - -(defun portable-class-of (obj) - #-(or cmu sbcl) (class-of obj) - #+sbcl (sb-pcl:class-of obj) - #+cmu (pcl:class-of obj)) - -(defun portable-class-name (obj) - #-(or cmu sbcl) (class-name obj) - #+sbcl (sb-pcl:class-name obj) - #+cmu (pcl:class-name obj)) - -(defun portable-class-slots (obj) - #+allegro (mop:class-slots obj) - #+lispworks (clos:class-slots obj) - #+sbcl (sb-pcl:class-slots obj) - #+(or cmu scl) (pcl:class-slots obj)) - -(defun portable-slot-name (obj) - #+allegro (mop::slot-definition-name obj) - #+lispworks (clos::slot-definition-name obj) - #+sbcl (sb-pcl::slot-definition-name obj) - #+(or cmu scl) (pcl::slot-definition-name obj)) - - -;; Slot definitions - - - -(defclass hyperobject-dsd (#+allegro mop::standard-direct-slot-definition - #+lispworks clos:standard-direct-slot-definition - #+sbcl sb-pcl::standard-direct-slot-definition - #+(or scl cmucl) pcl::standard-direct-slot-definition - ) - ((ho-type :initarg :ho-type :initform nil :accessor dsd-ho-type) - (format-func :initarg :format-func :initform nil :accessor dsd-format-func) - (subobject :initarg :subobject :initform nil :accessor dsd-subobject) - (reference :initarg :reference :initform nil :accessor dsd-reference) - )) - -(defclass hyperobject-esd (#+allegro mop::standard-effective-slot-definition - #+lispworks clos:standard-effective-slot-definition - #+sbcl sb-pcl::standard-effective-slot-definition - #+(or scl cmucl) pcl::standard-effective-slot-definition - ) - ((ho-type :initarg :ho-type :initform nil :accessor esd-ho-type) - (format-func :initarg :format-func :initform nil :accessor esd-format-func) - (subobject :initarg :subobject :initform nil :accessor esd-subobject) - (reference :initarg :reference :initform nil :accessor esd-reference) - )) - -;; Main class - -(defclass hyperobject-class (#-(or cmu sbcl) standard-class - #+cmu pcl::standard-class - #+sbcl sb-pcl::standard-class) - ((title :initarg :title :type string :reader ml-std-title - :documentation -"Print Title for class") - (subobjects - :initarg :subobjects - :documentation -"List of fields that contain a list of subobjects objects.") - (references - :initarg :references :type list :reader ml-std-references - :documentation - "List of fields that can be referred to by browsers. -Format is ((field-name field-lookup-func other-link-params) ...)") - - ;;; The remainder of these fields are calculated one time - ;;; in finalize-inheritence. - (value-func :initform nil :type function :reader ml-std-value-func) - (xmlvalue-func :initform nil :type function :reader ml-std-xmlvalue-func) - (fmtstr-text :initform nil :type string :reader ml-std-fmtstr-text) - (fmtstr-html :initform nil :type string :reader ml-std-fmtstr-html) - (fmtstr-xml :initform nil :type string :reader ml-std-fmtstr-xml) - (fmtstr-text-labels :initform nil :type string :reader ml-std-fmtstr-text-labels) - (fmtstr-html-labels :initform nil :type string :reader ml-std-fmtstr-html-labels) - (fmtstr-xml-labels :initform nil :type string :reader ml-std-fmtstr-xml-labels) - (fmtstr-html-ref :initform nil :type string :reader ml-std-fmtstr-html-ref) - (fmtstr-xml-ref :initform nil :type string :reader ml-std-fmtstr-xml-ref) - (fmtstr-html-ref-labels :initform nil :type string :reader ml-std-fmtstr-html-ref-labels) - (fmtstr-xml-ref-labels :initform nil :type string :reader ml-std-fmtstr-xml-ref-labels) - ) - (:default-initargs :title nil :subobjects nil :references nil) - (:documentation "Metaclass for Markup Language classes.")) - -(defclass subobject () - ((name :type symbol :initform nil :initarg :name :reader name) - (reader :type function :initform nil :initarg :reader :reader reader))) - -(defmethod print-object ((obj subobject) (s stream)) - (print-unreadable-object (obj s :type t :identity t) - (format s "~S" (name obj)))) - -(defclass reference () - ((name :type symbol :initform nil :initarg :name :reader name) - (lookup :type function :initform nil :initarg :lookup :reader lookup) - (link-parameters :type list :initform nil :initarg :link-parameters - :reader link-parameters))) - -(defmethod print-object ((obj reference) (s stream)) - (print-unreadable-object (obj s :type t :identity t) - (format s "~S" (name obj)))) - -#+cmu -(defmethod pcl:finalize-inheritance :after ((cl hyperobject-class)) - (init-hyperobject-class cl)) - -#+scl -(defmethod clos:finalize-inheritance :after ((cl hyperobject-class)) - (init-hyperobject-class cl)) - - -#+sbcl -(defmethod sb-pcl:finalize-inheritance :after ((cl hyperobject-class)) - (init-hyperobject-class cl)) - - -#+cmu -(defmethod pcl:validate-superclass ((class hyperobject-class) (superclass pcl::standard-class)) - t) - -#+scl -(defmethod clos:validate-superclass ((class hyperobject-class) (superclass standard-class)) - t) - -#+sbcl -(defmethod sb-pcl:validate-superclass ((class hyperobject-class) (superclass sb-pcl::standard-class)) - t) - -#+allegro -(defmethod mop:finalize-inheritance :after ((cl hyperobject-class)) - (init-hyperobject-class cl)) - -#+lispworks -(defmethod clos:finalize-inheritance :after ((cl hyperobject-class)) - (init-hyperobject-class cl)) - -;; Slot definitions -#+allegro -(defmethod mop:direct-slot-definition-class ((cl hyperobject-class) - &rest iargs) - (find-class 'hyperobject-dsd)) - -#+lispworks -(defmethod clos:direct-slot-definition-class ((cl hyperobject-class) iargs) - (find-class 'hyperobject-dsd)) - -#+sbcl -(defmethod sb-pcl:direct-slot-definition-class ((cl hyperobject-class) iargs) - (find-class 'hyperobject-dsd)) - -#+(or cmucl scl) -(defmethod pcl:direct-slot-definition-class ((cl hyperobject-class) iargs) - (find-class 'hyperobject-dsd)) - - - - -#+lispworks -(defmethod clos:process-a-class-option ((class hyperobject-class) - (name (eql :title)) - value) - (unless value - (error "hyperobject-class title must have a value")) - (if (null (cdr value)) - (list name (car value)) - (list name `',value))) - -(defmethod - #+allegro clos:compute-effective-slot-definition - #+lispworks clos:compute-effective-slot-definition - #+sbcl sb-pcl::compute-effective-slot-definition - #+(or cmucl scl) pcl::compute-effective-slot-definition - :around ((cl hyperobject-class) #+(or allegro lispworks) slot dsds) - (declare (ignorable slot)) - (let* ((dsd (car dsds)) - (ho-type (slot-value dsd 'type))) - (setf (slot-value dsd 'ho-type) ho-type) - (setf (slot-value dsd 'type) (convert-ho-type ho-type)) - (let ((ia - #+allegro (excl::compute-effective-slot-definition-initargs cl dsds) - #+lispworks (clos::compute-effective-slot-definition-initargs cl slot dsds) - #+sbcl (sb-pcl::compute-effective-slot-definition-initargs cl dsds) - #+(or cmucl scl) (pcl::compute-effective-slot-definition-initargs cl dsds) - )) - (apply - #'make-instance 'hyperobject-esd - :ho-type ho-type - :format-func (slot-value dsd 'format-func) - :subobject (slot-value dsd 'subobject) - :reference (slot-value dsd 'reference) - ia))) - ) - -(defun convert-ho-type (ho-type) - (check-type ho-type symbol) - (case (intern (symbol-name ho-type) (symbol-name :keyword)) - (:string - 'string) - (:fixnum - 'fixnum) - (:boolean - 'boolean) - (:integer - 'integer) - (:cdata - 'string) - (:float - 'float) - (otherwise - ho-type))) - -;;;; Class initialization function - -(defun init-hyperobject-class (cl) - (let ((fmtstr-text "") - (fmtstr-html "") - (fmtstr-xml "") - (fmtstr-text-labels "") - (fmtstr-html-labels "") - (fmtstr-xml-labels "") - (fmtstr-html-ref "") - (fmtstr-xml-ref "") - (fmtstr-html-ref-labels "") - (fmtstr-xml-ref-labels "") - (first-field t) - (value-func '()) - (xmlvalue-func '()) - (classname (portable-class-name cl)) - (package (symbol-package (portable-class-name cl))) - (references nil) - (subobjects nil)) - (declare (ignore classname)) - (dolist (f (portable-class-slots cl)) - (if (slot-value f 'subobject) - (push (make-instance 'subobject :name (portable-slot-name f) - :reader (if (eq t (esd-subobject f)) - (portable-slot-name f) - (esd-subobject f))) - subobjects) - (let ((name (portable-slot-name f)) - (namestr (symbol-name (portable-slot-name f))) - (namestr-lower (string-downcase (symbol-name (portable-slot-name f)))) - (type (slot-value f 'ho-type)) - (formatter (slot-value f 'format-func)) - (value-fmt "~a") - (plain-value-func nil) - html-str xml-str html-label-str xml-label-str) - - (when (or (eql type :integer) (eql type :fixnum)) - (setq value-fmt "~d")) - - (when (eql type :commainteger) - (setq value-fmt "~:d")) - - (when (eql type :boolean) - (setq value-fmt "~a")) - - (if first-field - (setq first-field nil) - (progn - (string-append fmtstr-text " ") - (string-append fmtstr-html " ") - (string-append fmtstr-xml " ") - (string-append fmtstr-text-labels " ") - (string-append fmtstr-html-labels " ") - (string-append fmtstr-xml-labels " ") - (string-append fmtstr-html-ref " ") - (string-append fmtstr-xml-ref " ") - (string-append fmtstr-html-ref-labels " ") - (string-append fmtstr-xml-ref-labels " "))) - - (setq html-str (concatenate 'string "" value-fmt "")) - (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "")) - (setq html-label-str (concatenate 'string "" namestr-lower " " value-fmt "")) - (setq xml-label-str (concatenate 'string " <" namestr-lower ">" value-fmt "")) - - (string-append fmtstr-text value-fmt) - (string-append fmtstr-html html-str) - (string-append fmtstr-xml xml-str) - (string-append fmtstr-text-labels namestr-lower " " value-fmt) - (string-append fmtstr-html-labels html-label-str) - (string-append fmtstr-xml-labels xml-label-str) - - (if (esd-reference f) - (progn - (string-append fmtstr-html-ref "<~~a>" value-fmt "") - (string-append fmtstr-xml-ref "<~~a>" value-fmt "") - (string-append fmtstr-html-ref-labels "" namestr-lower " <~~a>" value-fmt "") - (string-append fmtstr-xml-ref-labels " <~~a>" value-fmt "") - (push (make-instance 'reference :name name :lookup (esd-reference f)) - references)) - (progn - (string-append fmtstr-html-ref html-str) - (string-append fmtstr-xml-ref xml-str) - (string-append fmtstr-html-ref-labels html-label-str) - (string-append fmtstr-xml-ref-labels xml-label-str))) - - (if formatter - (setq plain-value-func - (list `(,formatter (,(intern namestr package) x)))) - (setq plain-value-func - (list `(,(intern namestr package) x)))) - (setq value-func (append value-func plain-value-func)) - - (if (eql type :cdata) - (setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func)))) - (setq xmlvalue-func (append xmlvalue-func plain-value-func))) - ))) - - (setf (slot-value cl 'references) references) - (setf (slot-value cl 'subobjects) subobjects) - - (if value-func - (setq value-func `(lambda (x) (values ,@value-func))) - (setq value-func `(lambda () (values)))) - (setq value-func (compile nil (eval value-func))) - - (if xmlvalue-func - (setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-func))) - (setq xmlvalue-func `(lambda () (values)))) - (setq xmlvalue-func (compile nil (eval xmlvalue-func))) - - (setf (slot-value cl 'fmtstr-text) fmtstr-text) - (setf (slot-value cl 'fmtstr-html) fmtstr-html) - (setf (slot-value cl 'fmtstr-xml) fmtstr-xml) - (setf (slot-value cl 'fmtstr-text-labels) fmtstr-text-labels) - (setf (slot-value cl 'fmtstr-html-labels) fmtstr-html-labels) - (setf (slot-value cl 'fmtstr-xml-labels) fmtstr-xml-labels) - (setf (slot-value cl 'fmtstr-html-ref) fmtstr-html-ref) - (setf (slot-value cl 'fmtstr-xml-ref) fmtstr-xml-ref) - (setf (slot-value cl 'fmtstr-html-ref-labels) fmtstr-html-ref-labels) - (setf (slot-value cl 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels) - (setf (slot-value cl 'value-func) value-func) - (setf (slot-value cl 'xmlvalue-func) xmlvalue-func)) - (values)) - - -(defun hyperobject-class-fmtstr-text (obj) - (slot-value (portable-class-of obj) 'fmtstr-text)) - -(defun hyperobject-class-fmtstr-html (obj) - (slot-value (portable-class-of obj) 'fmtstr-html)) - -(defun hyperobject-class-fmtstr-xml (obj) - (slot-value (portable-class-of obj) 'fmtstr-xml)) - -(defun hyperobject-class-fmtstr-text-labels (obj) - (slot-value (portable-class-of obj) 'fmtstr-text-labels)) - -(defun hyperobject-class-fmtstr-html-labels (obj) - (slot-value (portable-class-of obj) 'fmtstr-html-labels)) - -(defun hyperobject-class-fmtstr-xml-labels (obj) - (slot-value (portable-class-of obj) 'fmtstr-xml-labels)) - -(defun hyperobject-class-value-func (obj) - (slot-value (portable-class-of obj) 'value-func)) - -(defun hyperobject-class-xmlvalue-func (obj) - (slot-value (portable-class-of obj) 'xmlvalue-func)) - -(eval-when (:compile-toplevel :load-toplevel :execute) -(defun hyperobject-class-title (obj) - (awhen (slot-value (portable-class-of obj) 'title) - (if (consp it) - (car it) - it)))) - -(defun hyperobject-class-subobjects (obj) - (slot-value (portable-class-of obj) 'subobjects)) - -(defun hyperobject-class-references (obj) - (slot-value (portable-class-of obj) 'references)) - -(defun hyperobject-class-fields (obj) - (portable-class-slots (portable-class-of obj))) - -(defun hyperobject-class-fmtstr-html-ref (obj) - (slot-value (portable-class-of obj) 'fmtstr-html-ref)) - -(defun hyperobject-class-fmtstr-xml-ref (obj) - (slot-value (portable-class-of obj) 'fmtstr-xml-ref)) - -(defun hyperobject-class-fmtstr-html-ref-labels (obj) - (slot-value (portable-class-of obj) 'fmtstr-html-ref-labels)) - -(defun hyperobject-class-fmtstr-xml-ref-labels (obj) - (slot-value (portable-class-of obj) 'fmtstr-xml-ref-labels)) - -;;; Class name functions - -(defgeneric hyperobject-class-stdname (x)) -(defmethod hyperobject-class-stdname ((name string)) - (string-downcase (subseq name 1))) - -(defmethod hyperobject-class-stdname ((cl standard-object)) - (string-downcase (subseq (portable-class-name (portable-class-of cl)) 1))) - -;;;; Generic Print functions - -(defparameter *default-textformat* nil) -(defparameter *default-htmlformat* nil) -(defparameter *default-htmlrefformat* nil) -(defparameter *default-xhtmlformat* nil) -(defparameter *default-xhtmlrefformat* nil) -(defparameter *default-xmlformat* nil) -(defparameter *default-xmlrefformat* nil) -(defparameter *default-ie-xmlrefformat* nil) -(defparameter *default-nullformat* nil) -(defparameter *default-init-format?* nil) - -(defun make-format-instance (fmt) - (unless *default-init-format?* - (setq *default-textformat* (make-instance 'textformat)) - (setq *default-htmlformat* (make-instance 'htmlformat)) - (setq *default-htmlrefformat* (make-instance 'htmlrefformat)) - (setq *default-xhtmlformat* (make-instance 'xhtmlformat)) - (setq *default-xhtmlrefformat* (make-instance 'xhtmlrefformat)) - (setq *default-xmlformat* (make-instance 'xmlformat)) - (setq *default-xmlrefformat* (make-instance 'xmlrefformat)) - (setq *default-ie-xmlrefformat* (make-instance 'ie-xmlrefformat)) - (setq *default-nullformat* (make-instance 'nullformat)) - (setq *default-init-format?* t)) - - (case fmt - (:text *default-textformat*) - (:html *default-htmlformat*) - (:htmlref *default-htmlrefformat*) - (:xhtml *default-xhtmlformat*) - (:xhtmlref *default-xhtmlrefformat*) - (:xml *default-xmlformat*) - (:xmlref *default-xmlrefformat*) - (:ie-xmlref *default-ie-xmlrefformat*) - (:null *default-nullformat*) - (otherwise *default-textformat*))) - -;;;; Output format classes for print hyperobject-classes - -(defclass dataformat () - ((file-start-str :type string :initarg :file-start-str :reader file-start-str) - (file-end-str :type string :initarg :file-end-str :reader file-end-str) - (list-start-fmtstr :type string :initarg :list-start-fmtstr :reader list-start-fmtstr) - (list-start-value-func :type function :initarg :list-start-value-func :reader list-start-value-func) - (list-start-indent :initarg :list-start-indent :reader list-start-indent) - (list-end-fmtstr :type string :initarg :list-end-fmtstr :reader list-end-fmtstr) - (list-end-value-func :type function :initarg :list-end-value-func :reader list-end-value-func) - (list-end-indent :initarg :list-end-indent :reader list-end-indent) - (obj-start-fmtstr :type string :initarg :obj-start-fmtstr :reader obj-start-fmtstr) - (obj-start-value-func :initarg :obj-start-value-func :reader obj-start-value-func) - (obj-start-indent :initarg :obj-start-indent :reader obj-start-indent) - (obj-end-fmtstr :type string :initarg :obj-end-fmtstr :reader obj-end-fmtstr) - (obj-end-value-func :initarg :obj-end-value-func :reader obj-end-value-func) - (obj-end-indent :initarg :obj-end-indent :reader obj-end-indent) - (obj-data-indent :initarg :obj-data-indent :reader obj-data-indent) - (obj-data-fmtstr :initarg :obj-data-fmtstr :reader obj-data-fmtstr) - (obj-data-fmtstr-labels :initarg :obj-data-fmtstr-labels :reader obj-data-fmtstr-labels) - (obj-data-end-fmtstr :initarg :obj-data-end-fmtstr :reader obj-data-end-fmtstr) - (obj-data-value-func :initarg :obj-data-value-func :reader obj-data-value-func) - (link-ref :initarg :link-ref :reader link-ref)) - (:default-initargs :file-start-str nil :file-end-str nil :list-start-fmtstr nil :list-start-value-func nil - :list-start-indent nil :list-end-fmtstr nil :list-end-value-func nil :list-end-indent nil - :obj-start-fmtstr nil :obj-start-value-func nil :obj-start-indent nil - :obj-end-fmtstr nil :obj-end-value-func nil :obj-end-indent nil - :obj-data-indent nil :obj-data-fmtstr nil :obj-data-fmtstr-labels nil :obj-data-end-fmtstr nil - :obj-data-value-func nil :link-ref nil) - (:documentation "Parent for all dataformat objects")) - -(defclass binaryformat (dataformat) - ()) - -(defclass nullformat (dataformat) - ()) - -(defun text-list-start-value-func (obj nitems) - (values (hyperobject-class-title obj) nitems)) - -(defclass textformat (dataformat) - () - (:default-initargs :list-start-fmtstr "~a~P:~%" - :list-start-value-func #'text-list-start-value-func - :list-start-indent t - :obj-data-indent t - :obj-data-fmtstr #'hyperobject-class-fmtstr-text - :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-text-labels - :obj-data-end-fmtstr "~%" - :obj-data-value-func #'hyperobject-class-value-func)) - - -(defun class-name-of (obj) - (string-downcase (portable-class-name (portable-class-of obj)))) - -(defun htmlformat-list-start-value-func (x nitems) - (values (hyperobject-class-title x) nitems (class-name-of x))) - -(defclass htmlformat (textformat) - () - (:default-initargs :file-start-str "~%" - :file-end-str "~%" - :list-start-indent t - :list-start-fmtstr "

~a~p:

    ~%" - :list-start-value-func #'htmlformat-list-start-value-func - :list-end-fmtstr "
~%" - :list-end-indent t - :list-end-value-func #'identity - :obj-start-indent t - :obj-start-fmtstr "
  • " - :obj-start-value-func #'identity - :obj-end-indent t - :obj-end-fmtstr "
    • ~%" - :obj-end-value-func #'identity - :obj-data-indent t - :obj-data-fmtstr #'hyperobject-class-fmtstr-html-labels - :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-html-labels - :obj-data-value-func #'hyperobject-class-value-func)) - -(defclass xhtmlformat (textformat) - () - (:default-initargs :file-start-str "~%" - :file-end-str "~%" - :list-start-indent t - :list-start-fmtstr "

    ~a~p:

      ~%" - :list-start-value-func #'htmlformat-list-start-value-func - :list-end-fmtstr "
    ~%" - :list-end-indent t - :list-end-value-func #'identity - :obj-start-indent t - :obj-start-fmtstr "
  • " - :obj-start-value-func #'identity - :obj-end-indent t - :obj-end-fmtstr "
    • ~%" - :obj-end-value-func #'identity - :obj-data-indent t - :obj-data-fmtstr #'hyperobject-class-fmtstr-html-labels - :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-html-labels - :obj-data-value-func #'hyperobject-class-xmlvalue-func)) - - -(defun xmlformat-list-end-value-func (x) - (format nil "~alist" (class-name-of x))) - -(defun xmlformat-list-start-value-func (x nitems) - (values (format nil "~alist" (class-name-of x)) (hyperobject-class-title x) nitems)) - -(defclass xmlformat (textformat) - () - (:default-initargs :file-start-str "" ; (std-xml-header) - :list-start-indent t - :list-start-fmtstr "<~a>~a~p: ~%" - :list-start-value-func #'xmlformat-list-start-value-func - :list-end-indent t - :list-end-fmtstr "~%" - :list-end-value-func #'xmlformat-list-end-value-func - :obj-start-fmtstr "<~a>" - :obj-start-value-func #'class-name-of - :obj-start-indent t - :obj-end-fmtstr "~%" - :obj-end-value-func #'class-name-of - :obj-end-indent nil - :obj-data-indent nil - :obj-data-fmtstr #'hyperobject-class-fmtstr-xml - :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-xml-labels - :obj-data-value-func #'hyperobject-class-xmlvalue-func)) - -(defclass link-ref () - ((fmtstr :type function :initarg :fmtstr :accessor fmtstr) - (fmtstr-labels :type function :initarg :fmtstr-labels :accessor fmtstr-labels) - (page-name :type string :initarg :page-name :accessor page-name) - (href-head :type string :initarg :href-head :accessor href-head) - (href-end :type string :initarg :href-end :accessor href-end) - (ampersand :type string :initarg :ampersand :accessor ampersand)) - (:default-initargs :fmtstr nil - :fmtstr-labels nil - :page-name "disp-func1" - :href-head nil :href-end nil :ampersand nil) - (:documentation "Formatting for a linked reference")) - -(defclass html-link-ref (link-ref) - () - (:default-initargs :fmtstr #'hyperobject-class-fmtstr-html-ref - :fmtstr-labels #'hyperobject-class-fmtstr-html-ref-labels - :href-head "a href=" - :href-end "a" - :ampersand "&")) - -(defclass xhtml-link-ref (link-ref) - () - (:default-initargs :fmtstr #'hyperobject-class-fmtstr-html-ref - :fmtstr-labels #'hyperobject-class-fmtstr-html-ref-labels - :href-head "a href=" - :href-end "a" - :ampersand "&")) - -(defclass xml-link-ref (link-ref) - () - (:default-initargs :fmtstr #'hyperobject-class-fmtstr-xml-ref - :fmtstr-labels #'hyperobject-class-fmtstr-xml-ref-labels - :href-head "xmllink xlink:type=\"simple\" xlink:href=" - :href-end "xmllink" - :ampersand "&") - (:documentation "Mozilla's and W3's idea of a link with XML")) - -(defclass ie-xml-link-ref (xml-link-ref) - () - (:default-initargs :href-head "html:a href=" - :href-end "html:a" ) - (:documentation "Internet Explorer's idea of a link with XML")) - - -(defclass htmlrefformat (htmlformat) - () - (:default-initargs :link-ref (make-instance 'html-link-ref))) - -(defclass xhtmlrefformat (xhtmlformat) - () - (:default-initargs :link-ref (make-instance 'xhtml-link-ref))) - -(defclass xmlrefformat (xmlformat) - () - (:default-initargs :link-ref (make-instance 'xml-link-ref))) - -(defclass ie-xmlrefformat (xmlformat) - () - (:default-initargs :link-ref (make-instance 'ie-xml-link-ref))) - - -;;; File Start and Ends - -(defgeneric fmt-file-start (fmt s)) -(defmethod fmt-file-start ((fmt dataformat) (s stream))) - -(defmethod fmt-file-start ((fmt textformat) (s stream)) - (aif (file-start-str fmt) - (format s it))) - -(defgeneric fmt-file-end (fmt s)) -(defmethod fmt-file-end ((fmt textformat) (s stream)) - (aif (file-end-str fmt) - (format s it))) - -;;; List Start and Ends - -(defgeneric fmt-list-start (obj fmt s &optional indent num-items)) -(defmethod fmt-list-start (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1)) - (if (list-start-indent fmt) - (indent-spaces indent s)) - (aif (list-start-fmtstr fmt) - (apply #'format s it - (multiple-value-list - (funcall (list-start-value-func fmt) x num-items))))) - -(defgeneric fmt-list-end (obj fmt s &optional indent num-items)) -(defmethod fmt-list-end (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1)) - (declare (ignore num-items)) - (if (list-end-indent fmt) - (indent-spaces indent s)) - (aif (list-end-fmtstr fmt) - (apply #'format s it - (multiple-value-list - (funcall (list-end-value-func fmt) x))))) - -;;; Object Start and Ends - -(defgeneric fmt-obj-start (obj fmt s &optional indent)) -(defmethod fmt-obj-start (x (fmt textformat) (s stream) &optional (indent 0)) - (if (obj-start-indent fmt) - (indent-spaces indent s)) - (aif (obj-start-fmtstr fmt) - (apply #'format s it - (multiple-value-list - (funcall (obj-start-value-func fmt) x))))) - -(defgeneric fmt-obj-end (obj fmt s &optional indent)) -(defmethod fmt-obj-end (x (fmt textformat) (s stream) &optional (indent 0)) - (if (obj-end-indent fmt) - (indent-spaces indent s)) - (aif (obj-end-fmtstr fmt) - (apply #'format s it - (multiple-value-list - (funcall (obj-end-value-func fmt) x))))) - -;;; Object Data - -(defgeneric make-link-start (obj ref fieldname fieldfunc fieldvalue refvars)) -(defmethod make-link-start (obj (ref link-ref) fieldname fieldfunc fieldvalue refvars) - (declare (ignore obj fieldname)) - (format nil "~a\"~a?func=~a~akey=~a~a\"" - (href-head ref) (make-url (page-name ref)) fieldfunc - (ampersand ref) fieldvalue - (if refvars - (let ((varstr "")) - (dolist (var refvars) - (string-append varstr (format nil "~a~a=~a" - (ampersand ref) (car var) (cadr var)))) - varstr) - ""))) - -(defgeneric make-link-end (obj ref fieldname)) -(defmethod make-link-end (obj (ref link-ref) fieldname) - (declare (ignore obj fieldname)) - (format nil "~a" (href-end ref)) - ) - -(defgeneric fmt-obj-data (obj fmt s &optional indent label refvars)) -(defmethod fmt-obj-data (x (fmt textformat) s - &optional (indent 0) (label nil) (refvars nil)) - (if (obj-data-indent fmt) - (indent-spaces indent s)) - (if (link-ref fmt) - (fmt-obj-data-with-ref x fmt s label refvars) - (fmt-obj-data-plain x fmt s label)) - (aif (obj-data-end-fmtstr fmt) - (format s it))) - -(defgeneric fmt-obj-data-plain (obj fmt s label)) -(defmethod fmt-obj-data-plain (x (fmt textformat) s label) - (if label - (apply #'format s - (funcall (obj-data-fmtstr-labels fmt) x) - (multiple-value-list - (funcall (funcall (obj-data-value-func fmt) x) x))) - (apply #'format s (funcall (obj-data-fmtstr fmt) x) - (multiple-value-list - (funcall (funcall (obj-data-value-func fmt) x) x))))) - -(defgeneric fmt-obj-data-with-ref (obj fmt s label refvars)) -(defmethod fmt-obj-data-with-ref (x (fmt textformat) s label refvars) - (let ((refstr (make-ref-data-str x fmt label)) - (refvalues nil) - (field-values - (multiple-value-list - (funcall (funcall (obj-data-value-func fmt) x) x)))) - - ;; make list of reference link fields for printing to refstr template - (dolist (ref (hyperobject-class-references x)) - (let ((link-start - (make-link-start x (link-ref fmt) (name ref) (lookup ref) - (nth (position (name ref) - (hyperobject-class-fields x) - :key #'(lambda (x) - (portable-slot-name x))) - field-values) - (append (link-parameters ref) refvars))) - (link-end (make-link-end x (link-ref fmt) (name ref)))) - (push link-start refvalues) - (push link-end refvalues))) - (setq refvalues (nreverse refvalues)) - - (apply #'format s refstr refvalues))) - -(defgeneric obj-data (obj)) -(defmethod obj-data (x) - "Returns the objects data as a string. Used by common-graphics outline function" - (let ((fmt (make-format-instance :text))) - (apply #'format nil (funcall (obj-data-fmtstr fmt) x) - (multiple-value-list - (funcall (funcall (obj-data-value-func fmt) x) x))))) - -(defgeneric make-ref-data-str (obj fmt &optional label)) -(defmethod make-ref-data-str (x (fmt textformat) &optional (label nil)) - "Return fmt string for that contains ~a slots for reference link start and end" - (unless (link-ref fmt) - (error "fmt does not contain a link-ref")) - (let ((refstr - (if label - (apply #'format nil (funcall (fmtstr-labels (link-ref fmt)) x) - (multiple-value-list - (funcall (funcall (obj-data-value-func fmt) x) x))) - (apply #'format nil (funcall (fmtstr (link-ref fmt)) x) - (multiple-value-list (funcall (funcall (obj-data-value-func fmt) x) x)))))) - refstr)) - -;;; Display method for objects - - -(defgeneric load-all-subobjects (objs)) -(defmethod load-all-subobjects (objs) - "Load all subobjects if they have not already been loaded." - (when objs - (let ((objlist (mklist objs))) - (dolist (obj objlist) - (awhen (hyperobject-class-subobjects obj) ;; access list of functions - (dolist (child-obj it) ;; for each child function - (awhen (funcall (reader child-obj) obj) - (load-all-subobjects it)))))) - objs)) - -(defgeneric print-hyperobject-class (objs fmt strm - &optional label english-only-function - indent subobjects refvars)) - -(defmethod print-hyperobject-class (objs (fmt dataformat) (strm stream) - &optional (label nil) (indent 0) - (english-only-function nil) - (subobjects nil) (refvars nil)) -"Display a single or list of hyperobject-class instances and their subobjects" - (when objs - (setq objs (mklist objs)) - (let ((nobjs (length objs))) - (fmt-list-start (car objs) fmt strm indent nobjs) - (dolist (obj objs) - (unless (and english-only-function - (multiple-value-bind (eng term) (funcall english-only-function obj) - (and term (not eng)))) - (fmt-obj-start obj fmt strm indent) - (fmt-obj-data obj fmt strm (1+ indent) label refvars) - (if subobjects - (awhen (hyperobject-class-subobjects obj) ;; access list of functions - (dolist (child-obj it) ;; for each child function - (awhen (funcall (reader child-obj) obj) ;; access set of child objects - (print-hyperobject-class it fmt strm label - (1+ indent) english-only-function - subobjects refvars))))) - (fmt-obj-end obj fmt strm indent))) - (fmt-list-end (car objs) fmt strm indent nobjs)) - t)) - - - -(defun print-hyperobject (objs &key (os *standard-output*) (format :text) - (label nil) (english-only-function nil) - (subobjects nil) (file-wrapper t) (refvars nil)) - "EXPORTED Function: prints hyperobject-class objects. Simplies call to print-hyperobject-class" - (let ((fmt (make-format-instance format))) - (if file-wrapper - (fmt-file-start fmt os)) - (when objs - (print-hyperobject-class objs fmt os label 0 english-only-function subobjects refvars)) - (if file-wrapper - (fmt-file-end fmt os))) - objs) - - -(defclass hyperobject () - () - (:metaclass hyperobject-class)) - - -(defmethod print-object ((obj hyperobject) (s stream)) - (print-unreadable-object (obj s :type t :identity t) - (let ((fmt (make-instance 'hyperobject::textformat))) - (apply #'format - s (funcall (hyperobject-mop::obj-data-fmtstr fmt) obj) - (multiple-value-list - (funcall (funcall (hyperobject-mop::obj-data-value-func fmt) obj) obj)))))) - diff --git a/hyperobject-no-mop.lisp b/hyperobject-no-mop.lisp new file mode 100644 index 0000000..d0be74c --- /dev/null +++ b/hyperobject-no-mop.lisp @@ -0,0 +1,813 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: HYPEROBJECT -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: hyperobject.lisp +;;;; Purpose: Hyper Object (Plain - no Metaclass) +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Nov 2002 +;;;; +;;;; This is a rewrite of hyperobjec't to avoid using metaclasses. +;;;; +;;;; $Id: hyperobject-no-mop.lisp,v 1.1 2002/11/22 15:43:22 kevin Exp $ +;;;; +;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package :hyperobject) + + +(eval-when (:compile-toplevel :execute) + (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))) + + +;; Main class + +(defclass hyperobject () + ()) + +(defclass hyperobject-meta () + ((fields :initform nil :type list) + (subobjects :initform nil :type list) + (references :initform nil :type list) + (value-func :initform nil :type function) + (xml-value-func :initform nil :type function) + (fmtstr-text :initform nil :type string) + (fmtstr-html :initform nil :type string) + (fmtstr-xml :initform nil :type string) + (fmtstr-text-labels :initform nil :type string) + (fmtstr-html-labels :initform nil :type string) + (fmtstr-xml-labels :initform nil :type string) + (fmtstr-html-ref :initform nil :type string) + (fmtstr-xml-ref :initform nil :type string) + (fmtstr-html-ref-labels :initform nil :type string) + (fmtstr-xml-ref-labels :initform nil :type string) + ) + (:documentation "Class holding meta information for hyperobjects")) + +(defclass field () + ((name :type symbol :initform nil :initarg :name :reader name) + (format-func :initform nil :initarg :format-func :reader format-func) + (cl-type :initform nil :reader cl-type) + (ho-type :initform nil :reader ho-type) + (subobject :initform nil :reader subobject) + (reference :initform nil :reader reference) + )) + + +(defmethod print-object ((obj field) (s stream)) + (print-unreadable-object (obj s :type t :identity t) + (format s "~S" (name obj)))) + +(defclass subobject () + ((name :type symbol :initform nil :initarg :name :reader name) + (reader :type function :initform nil :initarg :reader :reader reader))) + +(defmethod print-object ((obj subobject) (s stream)) + (print-unreadable-object (obj s :type t :identity t) + (format s "~S" (name obj)))) + +(defclass reference () + ((name :type symbol :initform nil :initarg :name :reader name) + (lookup :type function :initform nil :initarg :lookup :reader lookup) + (link-parameters :type list :initform nil :initarg :link-parameters + :reader link-parameters))) + +(defmethod print-object ((obj reference) (s stream)) + (print-unreadable-object (obj s :type t :identity t) + (format s "~S" (name obj)))) + +(defun remove-keys (key-names args) + (loop for ( name val ) on args by #'cddr + unless (member (symbol-name name) key-names + :key #'symbol-name :test 'equal) + append (list name val))) + +(defun convert-ho-type (ho-type) + (check-type ho-type symbol) + (case (intern (symbol-name ho-type) (symbol-name :keyword)) + (:string + 'string) + (:fixnum + 'fixnum) + (:boolean + 'boolean) + (:integer + 'integer) + (:cdata + 'string) + (:float + 'float) + (otherwise + ho-type))) + +(defun process-hyper-fields (raw-fields meta) + (let* ((fields '()) + (references '()) + (subobjects '()) + (processed-fields + (loop for field in raw-fields + collecting + (destructuring-bind + (name &rest rest &key + ;; the following list of keywords is reproduced below in the + ;; remove-keys form. important to keep them in sync + type reader writer accessor initform format-func initarg + reference subobject + ;; list ends + &allow-other-keys) field + (let ((other-args (remove-keys + '(type reader writer accessor initform format-func + initarg reference subobject) + rest)) + (field-obj (make-instance 'field :name name)) + (kv nil)) + (declare (ignore other-args)) + (push field-obj fields) + (loop for (k v) in `((:type ,type) (:reader ,reader) (:writer ,writer) + (:accessor ,accessor) (:initform ,initform) + (:format-func ,format-func) (:initarg ,initarg) + (:subobject ,subobject) (:reference ,reference)) + do + (case k + (:initarg + (push (list :initarg + (if v + v + (intern (symbol-name name) + (symbol-name :keyword)))) + kv)) + (:accessor + (when v + (push (list :accessor v) kv))) + (:format-func + (when v + (setf (slot-value field-obj 'format-func) v))) + (:writer + (when v + (push (list :writer v) kv))) + (:reader + (if v + (push (list :reader v) kv) + (push (list :reader name) kv))) + (:type + (when v + (setf (slot-value field-obj 'ho-type) v) + (setf (slot-value field-obj 'cl-type) (convert-ho-type v)) + (push (list :type (cl-type field-obj)) kv))) + (:subobject + (when v + (let ((subobj (make-instance + 'subobject :name name + :reader + (if (eq v t) + name + v)))) + (setf (slot-value field-obj 'subobject) subobj) + (push subobj subobjects)))) + (:reference + (when v + (let ((ref (make-instance 'reference :name name :lookup v))) + (setf (slot-value field-obj 'reference) ref) + (push ref references)))) + )) + (append + (list name) + (loop for (k v) in kv + collecting k + collecting v))))))) + (setf (slot-value meta 'fields) (nreverse fields)) + (setf (slot-value meta 'references) (nreverse references)) + (setf (slot-value meta 'subobjects) (nreverse subobjects)) + processed-fields)) + + +(defun process-title (name meta) + (let ((title (cadr (assoc :title meta)))) + (if title + (if (symbolp title) + (symbol-name title) + title) + (symbol-name name)))) + +(defun process-documentation (meta) + (let ((doc (cadr (assoc :title meta)))) + (if (and doc (symbolp doc)) + (symbol-name doc) + doc))) + +(defun fmt-comma-integer (i) + (format nil "~:d" i)) + +;;;; Class initialization function +(defun init-hyperobject-class (name meta) + (let ((fmtstr-text "") + (fmtstr-html "") + (fmtstr-xml "") + (fmtstr-text-labels "") + (fmtstr-html-labels "") + (fmtstr-xml-labels "") + (fmtstr-html-ref "") + (fmtstr-xml-ref "") + (fmtstr-html-ref-labels "") + (fmtstr-xml-ref-labels "") + (first-field t) + (value-func '()) + (xml-value-func '()) + (package (symbol-package name))) + (dolist (field (slot-value meta 'fields)) + (declare (ignore rest)) + (let* ((name (name field)) + (format-func (format-func field)) + (type (ho-type field)) + (reference (reference field)) + (namestr (symbol-name name)) + (namestr-lower (string-downcase (symbol-name name))) + (value-fmt "~a") + (plain-value-func nil) + html-str xml-str html-label-str xml-label-str) + (unless (subobject field) + (when (or (eql type :integer) (eql type :fixnum)) + (setq value-fmt "~d")) + + (when (eql type :boolean) + (setq value-fmt "~a")) + + (if first-field + (setq first-field nil) + (progn + (string-append fmtstr-text " ") + (string-append fmtstr-html " ") + (string-append fmtstr-xml " ") + (string-append fmtstr-text-labels " ") + (string-append fmtstr-html-labels " ") + (string-append fmtstr-xml-labels " ") + (string-append fmtstr-html-ref " ") + (string-append fmtstr-xml-ref " ") + (string-append fmtstr-html-ref-labels " ") + (string-append fmtstr-xml-ref-labels " "))) + + (setq html-str (concatenate 'string "" value-fmt "")) + (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "")) + (setq html-label-str (concatenate 'string "" namestr-lower " " value-fmt "")) + (setq xml-label-str (concatenate 'string " <" namestr-lower ">" value-fmt "")) + + (string-append fmtstr-text value-fmt) + (string-append fmtstr-html html-str) + (string-append fmtstr-xml xml-str) + (string-append fmtstr-text-labels namestr-lower " " value-fmt) + (string-append fmtstr-html-labels html-label-str) + (string-append fmtstr-xml-labels xml-label-str) + + (if reference + (progn + (string-append fmtstr-html-ref "<~~a>" value-fmt "") + (string-append fmtstr-xml-ref "<~~a>" value-fmt "") + (string-append fmtstr-html-ref-labels "" namestr-lower " <~~a>" value-fmt "") + (string-append fmtstr-xml-ref-labels " <~~a>" value-fmt "")) + (progn + (string-append fmtstr-html-ref html-str) + (string-append fmtstr-xml-ref xml-str) + (string-append fmtstr-html-ref-labels html-label-str) + (string-append fmtstr-xml-ref-labels xml-label-str))) + + (if format-func + (setq plain-value-func + (list `(,format-func (,(intern namestr package) x)))) + (setq plain-value-func + (list `(,(intern namestr package) x)))) + (setq value-func (append value-func plain-value-func)) + + (if (eql type :cdata) + (setq xml-value-func (append xml-value-func (list `(xml-cdata ,@plain-value-func)))) + (setq xml-value-func (append xml-value-func plain-value-func))) + ))) + + (if value-func + (setq value-func `(lambda (x) (values ,@value-func))) + (setq value-func `(lambda () (values)))) + + (if xml-value-func + (setq xml-value-func `(lambda (x) (values ,@xml-value-func))) + (setq xml-value-func `(lambda () (values)))) + + (setf (slot-value meta 'fmtstr-text) fmtstr-text) + (setf (slot-value meta 'fmtstr-html) fmtstr-html) + (setf (slot-value meta 'fmtstr-xml) fmtstr-xml) + (setf (slot-value meta 'fmtstr-text-labels) fmtstr-text-labels) + (setf (slot-value meta 'fmtstr-html-labels) fmtstr-html-labels) + (setf (slot-value meta 'fmtstr-xml-labels) fmtstr-xml-labels) + (setf (slot-value meta 'fmtstr-html-ref) fmtstr-html-ref) + (setf (slot-value meta 'fmtstr-xml-ref) fmtstr-xml-ref) + (setf (slot-value meta 'fmtstr-html-ref-labels) fmtstr-html-ref-labels) + (setf (slot-value meta 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels) + (setf (slot-value meta 'value-func) value-func) + (setf (slot-value meta 'xml-value-func) xml-value-func)) + (values)) + +(defgeneric ho-title (obj) ) +(defgeneric ho-name (obj) ) +(defgeneric ho-value-func (obj) ) +(defgeneric ho-xml-value-func (obj) ) +(defgeneric ho-fmtstr-text (obj) ) +(defgeneric ho-fmtstr-html (obj) ) +(defgeneric ho-fmtstr-xml (obj) ) +(defgeneric ho-fmtstr-text-labels (obj) ) +(defgeneric ho-fmtstr-html-labels (obj) ) +(defgeneric ho-fmtstr-xml-labels (obj) ) +(defgeneric ho-fmtstr-html-ref (obj) ) +(defgeneric ho-fmtstr-xml-ref (obj) ) +(defgeneric ho-fmtstr-html-ref-labels (obj) ) +(defgeneric ho-fmtstr-xml-ref-labels (obj) ) +(defgeneric ho-fields (obj) ) +(defgeneric ho-references (obj) ) +(defgeneric ho-subobjects (obj) ) + +(defmacro define-hyperobject (name parents fields &rest meta-fields) + (let* ((meta (make-instance 'hyperobject-meta)) + (cl-fields (process-hyper-fields fields meta)) + (title (process-title name meta-fields)) + (documentation (process-documentation meta-fields)) + (value-func (gensym)) + (xml-value-func (gensym))) + (init-hyperobject-class name meta) + `(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (defclass ,name ,(append parents (list 'hyperobject)) ,cl-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)) + )))) + +;;;; Generic Print functions + +(defparameter *default-textformat* nil) +(defparameter *default-htmlformat* nil) +(defparameter *default-htmlrefformat* nil) +(defparameter *default-xhtmlformat* nil) +(defparameter *default-xhtmlrefformat* nil) +(defparameter *default-xmlformat* nil) +(defparameter *default-xmlrefformat* nil) +(defparameter *default-ie-xmlrefformat* nil) +(defparameter *default-nullformat* nil) +(defparameter *default-init-format?* nil) + +(defun make-format-instance (fmt) + (unless *default-init-format?* + (setq *default-textformat* (make-instance 'textformat)) + (setq *default-htmlformat* (make-instance 'htmlformat)) + (setq *default-htmlrefformat* (make-instance 'htmlrefformat)) + (setq *default-xhtmlformat* (make-instance 'xhtmlformat)) + (setq *default-xhtmlrefformat* (make-instance 'xhtmlrefformat)) + (setq *default-xmlformat* (make-instance 'xmlformat)) + (setq *default-xmlrefformat* (make-instance 'xmlrefformat)) + (setq *default-ie-xmlrefformat* (make-instance 'ie-xmlrefformat)) + (setq *default-nullformat* (make-instance 'nullformat)) + (setq *default-init-format?* t)) + + (case fmt + (:text *default-textformat*) + (:html *default-htmlformat*) + (:htmlref *default-htmlrefformat*) + (:xhtml *default-xhtmlformat*) + (:xhtmlref *default-xhtmlrefformat*) + (:xml *default-xmlformat*) + (:xmlref *default-xmlrefformat*) + (:ie-xmlref *default-ie-xmlrefformat*) + (:null *default-nullformat*) + (otherwise *default-textformat*))) + +;;;; Output format classes for print hoes + +(defclass dataformat () + ((file-start-str :type string :initarg :file-start-str :reader file-start-str) + (file-end-str :type string :initarg :file-end-str :reader file-end-str) + (list-start-fmtstr :type string :initarg :list-start-fmtstr :reader list-start-fmtstr) + (list-start-value-func :type function :initarg :list-start-value-func :reader list-start-value-func) + (list-start-indent :initarg :list-start-indent :reader list-start-indent) + (list-end-fmtstr :type string :initarg :list-end-fmtstr :reader list-end-fmtstr) + (list-end-value-func :type function :initarg :list-end-value-func :reader list-end-value-func) + (list-end-indent :initarg :list-end-indent :reader list-end-indent) + (obj-start-fmtstr :type string :initarg :obj-start-fmtstr :reader obj-start-fmtstr) + (obj-start-value-func :initarg :obj-start-value-func :reader obj-start-value-func) + (obj-start-indent :initarg :obj-start-indent :reader obj-start-indent) + (obj-end-fmtstr :type string :initarg :obj-end-fmtstr :reader obj-end-fmtstr) + (obj-end-value-func :initarg :obj-end-value-func :reader obj-end-value-func) + (obj-end-indent :initarg :obj-end-indent :reader obj-end-indent) + (obj-data-indent :initarg :obj-data-indent :reader obj-data-indent) + (obj-data-fmtstr :initarg :obj-data-fmtstr :reader obj-data-fmtstr) + (obj-data-fmtstr-labels :initarg :obj-data-fmtstr-labels :reader obj-data-fmtstr-labels) + (obj-data-end-fmtstr :initarg :obj-data-end-fmtstr :reader obj-data-end-fmtstr) + (obj-data-value-func :initarg :obj-data-value-func :reader obj-data-value-func) + (link-ref :initarg :link-ref :reader link-ref)) + (:default-initargs :file-start-str nil :file-end-str nil :list-start-fmtstr nil :list-start-value-func nil + :list-start-indent nil :list-end-fmtstr nil :list-end-value-func nil :list-end-indent nil + :obj-start-fmtstr nil :obj-start-value-func nil :obj-start-indent nil + :obj-end-fmtstr nil :obj-end-value-func nil :obj-end-indent nil + :obj-data-indent nil :obj-data-fmtstr nil :obj-data-fmtstr-labels nil :obj-data-end-fmtstr nil + :obj-data-value-func nil :link-ref nil) + (:documentation "Parent for all dataformat objects")) + +(defclass binaryformat (dataformat) + ()) + +(defclass nullformat (dataformat) + ()) + +(defun text-list-start-value-func (obj nitems) + (values (ho-title obj) nitems)) + +(defclass textformat (dataformat) + () + (:default-initargs :list-start-fmtstr "~a~P:~%" + :list-start-value-func #'text-list-start-value-func + :list-start-indent t + :obj-data-indent t + :obj-data-fmtstr #'ho-fmtstr-text + :obj-data-fmtstr-labels #'ho-fmtstr-text-labels + :obj-data-end-fmtstr "~%" + :obj-data-value-func #'ho-value-func)) + + +(defun htmlformat-list-start-value-func (x nitems) + (values (ho-title x) nitems (ho-name x))) + +(defclass htmlformat (textformat) + () + (:default-initargs :file-start-str "~%" + :file-end-str "~%" + :list-start-indent t + :list-start-fmtstr "

    ~a~p:

      ~%" + :list-start-value-func #'htmlformat-list-start-value-func + :list-end-fmtstr "
    ~%" + :list-end-indent t + :list-end-value-func #'identity + :obj-start-indent t + :obj-start-fmtstr "
  • " + :obj-start-value-func #'identity + :obj-end-indent t + :obj-end-fmtstr "
    • ~%" + :obj-end-value-func #'identity + :obj-data-indent t + :obj-data-fmtstr #'ho-fmtstr-html-labels + :obj-data-fmtstr-labels #'ho-fmtstr-html-labels + :obj-data-value-func #'ho-value-func)) + +(defclass xhtmlformat (textformat) + () + (:default-initargs :file-start-str "~%" + :file-end-str "~%" + :list-start-indent t + :list-start-fmtstr "

    ~a~p:

      ~%" + :list-start-value-func #'htmlformat-list-start-value-func + :list-end-fmtstr "
    ~%" + :list-end-indent t + :list-end-value-func #'identity + :obj-start-indent t + :obj-start-fmtstr "
  • " + :obj-start-value-func #'identity + :obj-end-indent t + :obj-end-fmtstr "
    • ~%" + :obj-end-value-func #'identity + :obj-data-indent t + :obj-data-fmtstr #'ho-fmtstr-html-labels + :obj-data-fmtstr-labels #'ho-fmtstr-html-labels + :obj-data-value-func #'ho-xml-value-func)) + + +(defun xmlformat-list-end-value-func (x) + (format nil "~alist" (ho-name x))) + +(defun xmlformat-list-start-value-func (x nitems) + (values (format nil "~alist" (ho-name x)) (ho-title x) nitems)) + +(defclass xmlformat (textformat) + () + (:default-initargs :file-start-str "" ; (std-xml-header) + :list-start-indent t + :list-start-fmtstr "<~a>~a~p: ~%" + :list-start-value-func #'xmlformat-list-start-value-func + :list-end-indent t + :list-end-fmtstr "~%" + :list-end-value-func #'xmlformat-list-end-value-func + :obj-start-fmtstr "<~a>" + :obj-start-value-func #'ho-name + :obj-start-indent t + :obj-end-fmtstr "~%" + :obj-end-value-func #'ho-name + :obj-end-indent nil + :obj-data-indent nil + :obj-data-fmtstr #'ho-fmtstr-xml + :obj-data-fmtstr-labels #'ho-fmtstr-xml-labels + :obj-data-value-func #'ho-xml-value-func)) + +(defclass link-ref () + ((fmtstr :type function :initarg :fmtstr :accessor fmtstr) + (fmtstr-labels :type function :initarg :fmtstr-labels :accessor fmtstr-labels) + (page-name :type string :initarg :page-name :accessor page-name) + (href-head :type string :initarg :href-head :accessor href-head) + (href-end :type string :initarg :href-end :accessor href-end) + (ampersand :type string :initarg :ampersand :accessor ampersand)) + (:default-initargs :fmtstr nil + :fmtstr-labels nil + :page-name "disp-func1" + :href-head nil :href-end nil :ampersand nil) + (:documentation "Formatting for a linked reference")) + +(defclass html-link-ref (link-ref) + () + (:default-initargs :fmtstr #'ho-fmtstr-html-ref + :fmtstr-labels #'ho-fmtstr-html-ref-labels + :href-head "a href=" + :href-end "a" + :ampersand "&")) + +(defclass xhtml-link-ref (link-ref) + () + (:default-initargs :fmtstr #'ho-fmtstr-html-ref + :fmtstr-labels #'ho-fmtstr-html-ref-labels + :href-head "a href=" + :href-end "a" + :ampersand "&")) + +(defclass xml-link-ref (link-ref) + () + (:default-initargs :fmtstr #'ho-fmtstr-xml-ref + :fmtstr-labels #'ho-fmtstr-xml-ref-labels + :href-head "xmllink xlink:type=\"simple\" xlink:href=" + :href-end "xmllink" + :ampersand "&") + (:documentation "Mozilla's and W3's idea of a link with XML")) + +(defclass ie-xml-link-ref (xml-link-ref) + () + (:default-initargs :href-head "html:a href=" + :href-end "html:a" ) + (:documentation "Internet Explorer's idea of a link with XML")) + + +(defclass htmlrefformat (htmlformat) + () + (:default-initargs :link-ref (make-instance 'html-link-ref))) + +(defclass xhtmlrefformat (xhtmlformat) + () + (:default-initargs :link-ref (make-instance 'xhtml-link-ref))) + +(defclass xmlrefformat (xmlformat) + () + (:default-initargs :link-ref (make-instance 'xml-link-ref))) + +(defclass ie-xmlrefformat (xmlformat) + () + (:default-initargs :link-ref (make-instance 'ie-xml-link-ref))) + + +;;; File Start and Ends + +(defgeneric fmt-file-start (fmt s)) +(defmethod fmt-file-start ((fmt dataformat) (s stream))) + +(defmethod fmt-file-start ((fmt textformat) (s stream)) + (aif (file-start-str fmt) + (format s it))) + +(defgeneric fmt-file-end (fmt s)) +(defmethod fmt-file-end ((fmt textformat) (s stream)) + (aif (file-end-str fmt) + (format s it))) + +;;; List Start and Ends + +(defgeneric fmt-list-start (obj fmt s &optional indent num-items)) +(defmethod fmt-list-start (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1)) + (if (list-start-indent fmt) + (indent-spaces indent s)) + (aif (list-start-fmtstr fmt) + (apply #'format s it + (multiple-value-list + (funcall (list-start-value-func fmt) x num-items))))) + +(defgeneric fmt-list-end (obj fmt s &optional indent num-items)) +(defmethod fmt-list-end (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1)) + (declare (ignore num-items)) + (if (list-end-indent fmt) + (indent-spaces indent s)) + (aif (list-end-fmtstr fmt) + (apply #'format s it + (multiple-value-list + (funcall (list-end-value-func fmt) x))))) + +;;; Object Start and Ends + +(defgeneric fmt-obj-start (obj fmt s &optional indent)) +(defmethod fmt-obj-start (x (fmt textformat) (s stream) &optional (indent 0)) + (if (obj-start-indent fmt) + (indent-spaces indent s)) + (aif (obj-start-fmtstr fmt) + (apply #'format s it + (multiple-value-list + (funcall (obj-start-value-func fmt) x))))) + +(defgeneric fmt-obj-end (obj fmt s &optional indent)) +(defmethod fmt-obj-end (x (fmt textformat) (s stream) &optional (indent 0)) + (if (obj-end-indent fmt) + (indent-spaces indent s)) + (aif (obj-end-fmtstr fmt) + (apply #'format s it + (multiple-value-list + (funcall (obj-end-value-func fmt) x))))) + +;;; Object Data + +(defgeneric make-link-start (obj ref fieldname fieldfunc fieldvalue refvars)) +(defmethod make-link-start (obj (ref link-ref) fieldname fieldfunc fieldvalue refvars) + (declare (ignore obj fieldname)) + (format nil "~a\"~a?func=~a~akey=~a~a\"" + (href-head ref) (make-url (page-name ref)) fieldfunc + (ampersand ref) fieldvalue + (if refvars + (let ((varstr "")) + (dolist (var refvars) + (string-append varstr (format nil "~a~a=~a" + (ampersand ref) (car var) (cadr var)))) + varstr) + ""))) + +(defgeneric make-link-end (obj ref fieldname)) +(defmethod make-link-end (obj (ref link-ref) fieldname) + (declare (ignore obj fieldname)) + (format nil "~a" (href-end ref)) + ) + +(defgeneric fmt-obj-data (obj fmt s &optional indent label refvars)) +(defmethod fmt-obj-data (x (fmt textformat) s + &optional (indent 0) (label nil) (refvars nil)) + (if (obj-data-indent fmt) + (indent-spaces indent s)) + (if (link-ref fmt) + (fmt-obj-data-with-ref x fmt s label refvars) + (fmt-obj-data-plain x fmt s label)) + (aif (obj-data-end-fmtstr fmt) + (format s it))) + +(defgeneric fmt-obj-data-plain (obj fmt s label)) +(defmethod fmt-obj-data-plain (x (fmt textformat) s label) + (if label + (apply #'format s + (funcall (obj-data-fmtstr-labels fmt) x) + (multiple-value-list + (funcall (funcall (obj-data-value-func fmt) x) x))) + (apply #'format s (funcall (obj-data-fmtstr fmt) x) + (multiple-value-list + (funcall (funcall (obj-data-value-func fmt) x) x))))) + +(defgeneric fmt-obj-data-with-ref (obj fmt s label refvars)) +(defmethod fmt-obj-data-with-ref (x (fmt textformat) s label refvars) + (let ((refstr (make-ref-data-str x fmt label)) + (refvalues nil) + (field-values + (multiple-value-list + (funcall (funcall (obj-data-value-func fmt) x) x)))) + + ;; make list of reference link fields for printing to refstr template + (dolist (ref (ho-references x)) + (let ((link-start + (make-link-start x (link-ref fmt) (name ref) (lookup ref) + (nth (position (name ref) (ho-fields x) + :key #'(lambda (x) (name x))) + field-values) + (append (link-parameters ref) refvars))) + (link-end (make-link-end x (link-ref fmt) (name ref)))) + (push link-start refvalues) + (push link-end refvalues))) + (setq refvalues (nreverse refvalues)) + + (apply #'format s refstr refvalues))) + +(defgeneric obj-data (obj)) +(defmethod obj-data (x) + "Returns the objects data as a string. Used by common-graphics outline function" + (let ((fmt (make-format-instance :text))) + (apply #'format nil (funcall (obj-data-fmtstr fmt) x) + (multiple-value-list + (funcall (funcall (obj-data-value-func fmt) x) x))))) + +(defgeneric make-ref-data-str (obj fmt &optional label)) +(defmethod make-ref-data-str (x (fmt textformat) &optional (label nil)) + "Return fmt string for that contains ~a slots for reference link start and end" + (unless (link-ref fmt) + (error "fmt does not contain a link-ref")) + (let ((refstr + (if label + (apply #'format nil (funcall (fmtstr-labels (link-ref fmt)) x) + (multiple-value-list + (funcall (funcall (obj-data-value-func fmt) x) x))) + (apply #'format nil (funcall (fmtstr (link-ref fmt)) x) + (multiple-value-list (funcall (funcall (obj-data-value-func fmt) x) x)))))) + refstr)) + +;;; Display method for objects + + +(defgeneric load-all-subobjects (objs)) +(defmethod load-all-subobjects (objs) + "Load all subobjects if they have not already been loaded." + (when objs + (let ((objlist (mklist objs))) + (dolist (obj objlist) + (awhen (ho-subobjects obj) ;; access list of functions + (dolist (subobj it) ;; for each child function + (awhen (funcall (reader subobj) obj) + (load-all-subobjects it)))))) + objs)) + +(defgeneric print-hyperobject-class (objs fmt strm + &optional label english-only-function + indent subobjects refvars)) + +(defmethod print-hyperobject-class (objs (fmt dataformat) (strm stream) + &optional (label nil) (indent 0) + (english-only-function nil) + (subobjects nil) (refvars nil)) +"Display a single or list of hyperobject-class instances and their subobjects" + (when objs + (setq objs (mklist objs)) + (let ((nobjs (length objs))) + (fmt-list-start (car objs) fmt strm indent nobjs) + (dolist (obj objs) + (unless (and english-only-function + (multiple-value-bind (eng term) (funcall english-only-function obj) + (and term (not eng)))) + (fmt-obj-start obj fmt strm indent) + (fmt-obj-data obj fmt strm (1+ indent) label refvars) + (if subobjects + (awhen (ho-subobjects obj) ;; access list of functions + (dolist (subobj it) ;; for each child function + (awhen (funcall (reader subobj) obj) ;; access set of child objects + (print-hyperobject-class it fmt strm label + (1+ indent) english-only-function + subobjects refvars))))) + (fmt-obj-end obj fmt strm indent))) + (fmt-list-end (car objs) fmt strm indent nobjs)) + t)) + + + +(defun print-hyperobject (objs &key (os *standard-output*) (format :text) + (label nil) (english-only-function nil) + (subobjects nil) (file-wrapper t) (refvars nil)) + "EXPORTED Function: prints hyperobject-class objects. Simplies call to print-hyperobject-class" + (let ((fmt (make-format-instance format))) + (if file-wrapper + (fmt-file-start fmt os)) + (when objs + (print-hyperobject-class objs fmt os label 0 english-only-function subobjects refvars)) + (if file-wrapper + (fmt-file-end fmt os))) + objs) + + +(defmethod print-object ((obj hyperobject) (s stream)) + (print-unreadable-object (obj s :type t :identity t) + (let ((fmt (make-instance 'hyperobject::textformat))) + (apply #'format + s (funcall (hyperobject::obj-data-fmtstr fmt) obj) + (multiple-value-list + (funcall (funcall (hyperobject::obj-data-value-func fmt) obj) obj)))))) + diff --git a/hyperobject.asd b/hyperobject.asd index 3b64976..8057acd 100644 --- a/hyperobject.asd +++ b/hyperobject.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: hyperobject.asd,v 1.5 2002/11/22 12:16:03 kevin Exp $ +;;;; $Id: hyperobject.asd,v 1.6 2002/11/22 15:43:22 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -20,8 +20,8 @@ :components ((:file "package") #+(or allegro lispworks sbcl cmucl scl) - (:file "hyperobject-mop" :depends-on ("package")) - (:file "hyperobject" :depends-on ("package"))) + (:file "hyperobject" :depends-on ("package")) + (:file "hyperobject-no-mop" :depends-on ("package"))) :depends-on (:kmrcl)) diff --git a/hyperobject.lisp b/hyperobject.lisp index 95d9c0b..ee71a8f 100644 --- a/hyperobject.lisp +++ b/hyperobject.lisp @@ -1,64 +1,115 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: HYPEROBJECT -*- +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: hyperobject.lisp -;;;; Purpose: Hyper Object (Plain - no Metaclass) +;;;; Purpose: Hyper Object Metaclass ;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Nov 2002 +;;;; Date Started: Apr 2000 ;;;; -;;;; This is a rewrite of hyperobjec't to avoid using metaclasses. +;;;; This metaclass as functions to classes to allow display +;;;; in Text, HTML, and XML formats. This includes hyperlinking +;;;; capability and sub-objects. ;;;; -;;;; $Id: hyperobject.lisp,v 1.5 2002/11/22 10:49:24 kevin Exp $ +;;;; $Id: hyperobject.lisp,v 1.6 2002/11/22 15:43:22 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; ;;;; ************************************************************************* -(in-package :hyperobject) +(in-package :hyperobject-mop) (eval-when (:compile-toplevel :execute) (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))) -;; Main class +;; Utilities -(defclass hyperobject () - ()) +(defun portable-class-of (obj) + #-(or cmu sbcl) (class-of obj) + #+sbcl (sb-pcl:class-of obj) + #+cmu (pcl:class-of obj)) -(defclass hyperobject-meta () - ((fields :initform nil :type list) - (subobjects :initform nil :type list) - (references :initform nil :type list) - (value-func :initform nil :type function) - (xml-value-func :initform nil :type function) - (fmtstr-text :initform nil :type string) - (fmtstr-html :initform nil :type string) - (fmtstr-xml :initform nil :type string) - (fmtstr-text-labels :initform nil :type string) - (fmtstr-html-labels :initform nil :type string) - (fmtstr-xml-labels :initform nil :type string) - (fmtstr-html-ref :initform nil :type string) - (fmtstr-xml-ref :initform nil :type string) - (fmtstr-html-ref-labels :initform nil :type string) - (fmtstr-xml-ref-labels :initform nil :type string) - ) - (:documentation "Class holding meta information for hyperobjects")) +(defun portable-class-name (obj) + #-(or cmu sbcl) (class-name obj) + #+sbcl (sb-pcl:class-name obj) + #+cmu (pcl:class-name obj)) -(defclass field () - ((name :type symbol :initform nil :initarg :name :reader name) - (format-func :initform nil :initarg :format-func :reader format-func) - (cl-type :initform nil :reader cl-type) - (ho-type :initform nil :reader ho-type) - (subobject :initform nil :reader subobject) - (reference :initform nil :reader reference) +(defun portable-class-slots (obj) + #+allegro (mop:class-slots obj) + #+lispworks (clos:class-slots obj) + #+sbcl (sb-pcl:class-slots obj) + #+(or cmu scl) (pcl:class-slots obj)) + +(defun portable-slot-name (obj) + #+allegro (mop::slot-definition-name obj) + #+lispworks (clos::slot-definition-name obj) + #+sbcl (sb-pcl::slot-definition-name obj) + #+(or cmu scl) (pcl::slot-definition-name obj)) + + +;; Slot definitions + + + +(defclass hyperobject-dsd (#+allegro mop::standard-direct-slot-definition + #+lispworks clos:standard-direct-slot-definition + #+sbcl sb-pcl::standard-direct-slot-definition + #+(or scl cmucl) pcl::standard-direct-slot-definition + ) + ((ho-type :initarg :ho-type :initform nil :accessor dsd-ho-type) + (format-func :initarg :format-func :initform nil :accessor dsd-format-func) + (subobject :initarg :subobject :initform nil :accessor dsd-subobject) + (reference :initarg :reference :initform nil :accessor dsd-reference) )) +(defclass hyperobject-esd (#+allegro mop::standard-effective-slot-definition + #+lispworks clos:standard-effective-slot-definition + #+sbcl sb-pcl::standard-effective-slot-definition + #+(or scl cmucl) pcl::standard-effective-slot-definition + ) + ((ho-type :initarg :ho-type :initform nil :accessor esd-ho-type) + (format-func :initarg :format-func :initform nil :accessor esd-format-func) + (subobject :initarg :subobject :initform nil :accessor esd-subobject) + (reference :initarg :reference :initform nil :accessor esd-reference) + )) -(defmethod print-object ((obj field) (s stream)) - (print-unreadable-object (obj s :type t :identity t) - (format s "~S" (name obj)))) +;; Main class + +(defclass hyperobject-class (#-(or cmu sbcl) standard-class + #+cmu pcl::standard-class + #+sbcl sb-pcl::standard-class) + ((title :initarg :title :type string :reader ml-std-title + :documentation +"Print Title for class") + (subobjects + :initarg :subobjects + :documentation +"List of fields that contain a list of subobjects objects.") + (references + :initarg :references :type list :reader ml-std-references + :documentation + "List of fields that can be referred to by browsers. +Format is ((field-name field-lookup-func other-link-params) ...)") + + ;;; The remainder of these fields are calculated one time + ;;; in finalize-inheritence. + (value-func :initform nil :type function :reader ml-std-value-func) + (xmlvalue-func :initform nil :type function :reader ml-std-xmlvalue-func) + (fmtstr-text :initform nil :type string :reader ml-std-fmtstr-text) + (fmtstr-html :initform nil :type string :reader ml-std-fmtstr-html) + (fmtstr-xml :initform nil :type string :reader ml-std-fmtstr-xml) + (fmtstr-text-labels :initform nil :type string :reader ml-std-fmtstr-text-labels) + (fmtstr-html-labels :initform nil :type string :reader ml-std-fmtstr-html-labels) + (fmtstr-xml-labels :initform nil :type string :reader ml-std-fmtstr-xml-labels) + (fmtstr-html-ref :initform nil :type string :reader ml-std-fmtstr-html-ref) + (fmtstr-xml-ref :initform nil :type string :reader ml-std-fmtstr-xml-ref) + (fmtstr-html-ref-labels :initform nil :type string :reader ml-std-fmtstr-html-ref-labels) + (fmtstr-xml-ref-labels :initform nil :type string :reader ml-std-fmtstr-xml-ref-labels) + ) + (:default-initargs :title nil :subobjects nil :references nil) + (:documentation "Metaclass for Markup Language classes.")) (defclass subobject () ((name :type symbol :initform nil :initarg :name :reader name) @@ -77,12 +128,97 @@ (defmethod print-object ((obj reference) (s stream)) (print-unreadable-object (obj s :type t :identity t) (format s "~S" (name obj)))) - -(defun remove-keys (key-names args) - (loop for ( name val ) on args by #'cddr - unless (member (symbol-name name) key-names - :key #'symbol-name :test 'equal) - append (list name val))) + +#+cmu +(defmethod pcl:finalize-inheritance :after ((cl hyperobject-class)) + (init-hyperobject-class cl)) + +#+scl +(defmethod clos:finalize-inheritance :after ((cl hyperobject-class)) + (init-hyperobject-class cl)) + + +#+sbcl +(defmethod sb-pcl:finalize-inheritance :after ((cl hyperobject-class)) + (init-hyperobject-class cl)) + + +#+cmu +(defmethod pcl:validate-superclass ((class hyperobject-class) (superclass pcl::standard-class)) + t) + +#+scl +(defmethod clos:validate-superclass ((class hyperobject-class) (superclass standard-class)) + t) + +#+sbcl +(defmethod sb-pcl:validate-superclass ((class hyperobject-class) (superclass sb-pcl::standard-class)) + t) + +#+allegro +(defmethod mop:finalize-inheritance :after ((cl hyperobject-class)) + (init-hyperobject-class cl)) + +#+lispworks +(defmethod clos:finalize-inheritance :after ((cl hyperobject-class)) + (init-hyperobject-class cl)) + +;; Slot definitions +#+allegro +(defmethod mop:direct-slot-definition-class ((cl hyperobject-class) + &rest iargs) + (find-class 'hyperobject-dsd)) + +#+lispworks +(defmethod clos:direct-slot-definition-class ((cl hyperobject-class) iargs) + (find-class 'hyperobject-dsd)) + +#+sbcl +(defmethod sb-pcl:direct-slot-definition-class ((cl hyperobject-class) iargs) + (find-class 'hyperobject-dsd)) + +#+(or cmucl scl) +(defmethod pcl:direct-slot-definition-class ((cl hyperobject-class) iargs) + (find-class 'hyperobject-dsd)) + + + + +#+lispworks +(defmethod clos:process-a-class-option ((class hyperobject-class) + (name (eql :title)) + value) + (unless value + (error "hyperobject-class title must have a value")) + (if (null (cdr value)) + (list name (car value)) + (list name `',value))) + +(defmethod + #+allegro clos:compute-effective-slot-definition + #+lispworks clos:compute-effective-slot-definition + #+sbcl sb-pcl::compute-effective-slot-definition + #+(or cmucl scl) pcl::compute-effective-slot-definition + :around ((cl hyperobject-class) #+(or allegro lispworks) slot dsds) + (declare (ignorable slot)) + (let* ((dsd (car dsds)) + (ho-type (slot-value dsd 'type))) + (setf (slot-value dsd 'ho-type) ho-type) + (setf (slot-value dsd 'type) (convert-ho-type ho-type)) + (let ((ia + #+allegro (excl::compute-effective-slot-definition-initargs cl dsds) + #+lispworks (clos::compute-effective-slot-definition-initargs cl slot dsds) + #+sbcl (sb-pcl::compute-effective-slot-definition-initargs cl dsds) + #+(or cmucl scl) (pcl::compute-effective-slot-definition-initargs cl dsds) + )) + (apply + #'make-instance 'hyperobject-esd + :ho-type ho-type + :format-func (slot-value dsd 'format-func) + :subobject (slot-value dsd 'subobject) + :reference (slot-value dsd 'reference) + ia))) + ) (defun convert-ho-type (ho-type) (check-type ho-type symbol) @@ -102,106 +238,9 @@ (otherwise ho-type))) -(defun process-hyper-fields (raw-fields meta) - (let* ((fields '()) - (references '()) - (subobjects '()) - (processed-fields - (loop for field in raw-fields - collecting - (destructuring-bind - (name &rest rest &key - ;; the following list of keywords is reproduced below in the - ;; remove-keys form. important to keep them in sync - type reader writer accessor initform format-func initarg - reference subobject - ;; list ends - &allow-other-keys) field - (let ((other-args (remove-keys - '(type reader writer accessor initform format-func - initarg reference subobject) - rest)) - (field-obj (make-instance 'field :name name)) - (kv nil)) - (declare (ignore other-args)) - (push field-obj fields) - (loop for (k v) in `((:type ,type) (:reader ,reader) (:writer ,writer) - (:accessor ,accessor) (:initform ,initform) - (:format-func ,format-func) (:initarg ,initarg) - (:subobject ,subobject) (:reference ,reference)) - do - (case k - (:initarg - (push (list :initarg - (if v - v - (intern (symbol-name name) - (symbol-name :keyword)))) - kv)) - (:accessor - (when v - (push (list :accessor v) kv))) - (:format-func - (when v - (setf (slot-value field-obj 'format-func) v))) - (:writer - (when v - (push (list :writer v) kv))) - (:reader - (if v - (push (list :reader v) kv) - (push (list :reader name) kv))) - (:type - (when v - (setf (slot-value field-obj 'ho-type) v) - (setf (slot-value field-obj 'cl-type) (convert-ho-type v)) - (push (list :type (cl-type field-obj)) kv))) - (:subobject - (when v - (let ((subobj (make-instance - 'subobject :name name - :reader - (if (eq v t) - name - v)))) - (setf (slot-value field-obj 'subobject) subobj) - (push subobj subobjects)))) - (:reference - (when v - (let ((ref (make-instance 'reference :name name :lookup v))) - (setf (slot-value field-obj 'reference) ref) - (push ref references)))) - )) - (append - (list name) - (loop for (k v) in kv - collecting k - collecting v))))))) - (setf (slot-value meta 'fields) (nreverse fields)) - (setf (slot-value meta 'references) (nreverse references)) - (setf (slot-value meta 'subobjects) (nreverse subobjects)) - processed-fields)) - - -(defun process-title (name meta) - (let ((title (cadr (assoc :title meta)))) - (if title - (if (symbolp title) - (symbol-name title) - title) - (symbol-name name)))) - -(defun process-documentation (meta) - (let ((doc (cadr (assoc :title meta)))) - (if (and doc (symbolp doc)) - (symbol-name doc) - doc))) - -(defun fmt-comma-integer (i) - (format nil "~:d" i)) - ;;;; Class initialization function -(defun init-hyperobject-class (name meta) + +(defun init-hyperobject-class (cl) (let ((fmtstr-text "") (fmtstr-html "") (fmtstr-xml "") @@ -214,166 +253,178 @@ (fmtstr-xml-ref-labels "") (first-field t) (value-func '()) - (xml-value-func '()) - (package (symbol-package name))) - (dolist (field (slot-value meta 'fields)) - (declare (ignore rest)) - (let* ((name (name field)) - (format-func (format-func field)) - (type (ho-type field)) - (reference (reference field)) - (namestr (symbol-name name)) - (namestr-lower (string-downcase (symbol-name name))) - (value-fmt "~a") - (plain-value-func nil) - html-str xml-str html-label-str xml-label-str) - (unless (subobject field) - (when (or (eql type :integer) (eql type :fixnum)) - (setq value-fmt "~d")) - - (when (eql type :boolean) - (setq value-fmt "~a")) - - (if first-field - (setq first-field nil) - (progn - (string-append fmtstr-text " ") - (string-append fmtstr-html " ") - (string-append fmtstr-xml " ") - (string-append fmtstr-text-labels " ") - (string-append fmtstr-html-labels " ") - (string-append fmtstr-xml-labels " ") - (string-append fmtstr-html-ref " ") - (string-append fmtstr-xml-ref " ") - (string-append fmtstr-html-ref-labels " ") - (string-append fmtstr-xml-ref-labels " "))) - - (setq html-str (concatenate 'string "" value-fmt "")) - (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "")) - (setq html-label-str (concatenate 'string "" namestr-lower " " value-fmt "")) - (setq xml-label-str (concatenate 'string " <" namestr-lower ">" value-fmt "")) - - (string-append fmtstr-text value-fmt) - (string-append fmtstr-html html-str) - (string-append fmtstr-xml xml-str) - (string-append fmtstr-text-labels namestr-lower " " value-fmt) - (string-append fmtstr-html-labels html-label-str) - (string-append fmtstr-xml-labels xml-label-str) - - (if reference - (progn - (string-append fmtstr-html-ref "<~~a>" value-fmt "") - (string-append fmtstr-xml-ref "<~~a>" value-fmt "") - (string-append fmtstr-html-ref-labels "" namestr-lower " <~~a>" value-fmt "") - (string-append fmtstr-xml-ref-labels " <~~a>" value-fmt "")) - (progn - (string-append fmtstr-html-ref html-str) - (string-append fmtstr-xml-ref xml-str) - (string-append fmtstr-html-ref-labels html-label-str) - (string-append fmtstr-xml-ref-labels xml-label-str))) - - (if format-func - (setq plain-value-func - (list `(,format-func (,(intern namestr package) x)))) - (setq plain-value-func - (list `(,(intern namestr package) x)))) - (setq value-func (append value-func plain-value-func)) - - (if (eql type :cdata) - (setq xml-value-func (append xml-value-func (list `(xml-cdata ,@plain-value-func)))) - (setq xml-value-func (append xml-value-func plain-value-func))) - ))) - + (xmlvalue-func '()) + (classname (portable-class-name cl)) + (package (symbol-package (portable-class-name cl))) + (references nil) + (subobjects nil)) + (declare (ignore classname)) + (dolist (f (portable-class-slots cl)) + (if (slot-value f 'subobject) + (push (make-instance 'subobject :name (portable-slot-name f) + :reader (if (eq t (esd-subobject f)) + (portable-slot-name f) + (esd-subobject f))) + subobjects) + (let ((name (portable-slot-name f)) + (namestr (symbol-name (portable-slot-name f))) + (namestr-lower (string-downcase (symbol-name (portable-slot-name f)))) + (type (slot-value f 'ho-type)) + (formatter (slot-value f 'format-func)) + (value-fmt "~a") + (plain-value-func nil) + html-str xml-str html-label-str xml-label-str) + + (when (or (eql type :integer) (eql type :fixnum)) + (setq value-fmt "~d")) + + (when (eql type :commainteger) + (setq value-fmt "~:d")) + + (when (eql type :boolean) + (setq value-fmt "~a")) + + (if first-field + (setq first-field nil) + (progn + (string-append fmtstr-text " ") + (string-append fmtstr-html " ") + (string-append fmtstr-xml " ") + (string-append fmtstr-text-labels " ") + (string-append fmtstr-html-labels " ") + (string-append fmtstr-xml-labels " ") + (string-append fmtstr-html-ref " ") + (string-append fmtstr-xml-ref " ") + (string-append fmtstr-html-ref-labels " ") + (string-append fmtstr-xml-ref-labels " "))) + + (setq html-str (concatenate 'string "" value-fmt "")) + (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "")) + (setq html-label-str (concatenate 'string "" namestr-lower " " value-fmt "")) + (setq xml-label-str (concatenate 'string " <" namestr-lower ">" value-fmt "")) + + (string-append fmtstr-text value-fmt) + (string-append fmtstr-html html-str) + (string-append fmtstr-xml xml-str) + (string-append fmtstr-text-labels namestr-lower " " value-fmt) + (string-append fmtstr-html-labels html-label-str) + (string-append fmtstr-xml-labels xml-label-str) + + (if (esd-reference f) + (progn + (string-append fmtstr-html-ref "<~~a>" value-fmt "") + (string-append fmtstr-xml-ref "<~~a>" value-fmt "") + (string-append fmtstr-html-ref-labels "" namestr-lower " <~~a>" value-fmt "") + (string-append fmtstr-xml-ref-labels " <~~a>" value-fmt "") + (push (make-instance 'reference :name name :lookup (esd-reference f)) + references)) + (progn + (string-append fmtstr-html-ref html-str) + (string-append fmtstr-xml-ref xml-str) + (string-append fmtstr-html-ref-labels html-label-str) + (string-append fmtstr-xml-ref-labels xml-label-str))) + + (if formatter + (setq plain-value-func + (list `(,formatter (,(intern namestr package) x)))) + (setq plain-value-func + (list `(,(intern namestr package) x)))) + (setq value-func (append value-func plain-value-func)) + + (if (eql type :cdata) + (setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func)))) + (setq xmlvalue-func (append xmlvalue-func plain-value-func))) + ))) + + (setf (slot-value cl 'references) references) + (setf (slot-value cl 'subobjects) subobjects) + (if value-func (setq value-func `(lambda (x) (values ,@value-func))) - (setq value-func `(lambda () (values)))) + (setq value-func `(lambda () (values)))) + (setq value-func (compile nil (eval value-func))) - (if xml-value-func - (setq xml-value-func `(lambda (x) (values ,@xml-value-func))) - (setq xml-value-func `(lambda () (values)))) - - (setf (slot-value meta 'fmtstr-text) fmtstr-text) - (setf (slot-value meta 'fmtstr-html) fmtstr-html) - (setf (slot-value meta 'fmtstr-xml) fmtstr-xml) - (setf (slot-value meta 'fmtstr-text-labels) fmtstr-text-labels) - (setf (slot-value meta 'fmtstr-html-labels) fmtstr-html-labels) - (setf (slot-value meta 'fmtstr-xml-labels) fmtstr-xml-labels) - (setf (slot-value meta 'fmtstr-html-ref) fmtstr-html-ref) - (setf (slot-value meta 'fmtstr-xml-ref) fmtstr-xml-ref) - (setf (slot-value meta 'fmtstr-html-ref-labels) fmtstr-html-ref-labels) - (setf (slot-value meta 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels) - (setf (slot-value meta 'value-func) value-func) - (setf (slot-value meta 'xml-value-func) xml-value-func)) + (if xmlvalue-func + (setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-func))) + (setq xmlvalue-func `(lambda () (values)))) + (setq xmlvalue-func (compile nil (eval xmlvalue-func))) + + (setf (slot-value cl 'fmtstr-text) fmtstr-text) + (setf (slot-value cl 'fmtstr-html) fmtstr-html) + (setf (slot-value cl 'fmtstr-xml) fmtstr-xml) + (setf (slot-value cl 'fmtstr-text-labels) fmtstr-text-labels) + (setf (slot-value cl 'fmtstr-html-labels) fmtstr-html-labels) + (setf (slot-value cl 'fmtstr-xml-labels) fmtstr-xml-labels) + (setf (slot-value cl 'fmtstr-html-ref) fmtstr-html-ref) + (setf (slot-value cl 'fmtstr-xml-ref) fmtstr-xml-ref) + (setf (slot-value cl 'fmtstr-html-ref-labels) fmtstr-html-ref-labels) + (setf (slot-value cl 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels) + (setf (slot-value cl 'value-func) value-func) + (setf (slot-value cl 'xmlvalue-func) xmlvalue-func)) (values)) -(defgeneric ho-title (obj) ) -(defgeneric ho-name (obj) ) -(defgeneric ho-value-func (obj) ) -(defgeneric ho-xml-value-func (obj) ) -(defgeneric ho-fmtstr-text (obj) ) -(defgeneric ho-fmtstr-html (obj) ) -(defgeneric ho-fmtstr-xml (obj) ) -(defgeneric ho-fmtstr-text-labels (obj) ) -(defgeneric ho-fmtstr-html-labels (obj) ) -(defgeneric ho-fmtstr-xml-labels (obj) ) -(defgeneric ho-fmtstr-html-ref (obj) ) -(defgeneric ho-fmtstr-xml-ref (obj) ) -(defgeneric ho-fmtstr-html-ref-labels (obj) ) -(defgeneric ho-fmtstr-xml-ref-labels (obj) ) -(defgeneric ho-fields (obj) ) -(defgeneric ho-references (obj) ) -(defgeneric ho-subobjects (obj) ) - -(defmacro define-hyperobject (name parents fields &rest meta-fields) - (let* ((meta (make-instance 'hyperobject-meta)) - (cl-fields (process-hyper-fields fields meta)) - (title (process-title name meta-fields)) - (documentation (process-documentation meta-fields)) - (value-func (gensym)) - (xml-value-func (gensym))) - (init-hyperobject-class name meta) - `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (defclass ,name ,(append parents (list 'hyperobject)) ,cl-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)) - )))) +(defun hyperobject-class-fmtstr-text (obj) + (slot-value (portable-class-of obj) 'fmtstr-text)) + +(defun hyperobject-class-fmtstr-html (obj) + (slot-value (portable-class-of obj) 'fmtstr-html)) + +(defun hyperobject-class-fmtstr-xml (obj) + (slot-value (portable-class-of obj) 'fmtstr-xml)) + +(defun hyperobject-class-fmtstr-text-labels (obj) + (slot-value (portable-class-of obj) 'fmtstr-text-labels)) + +(defun hyperobject-class-fmtstr-html-labels (obj) + (slot-value (portable-class-of obj) 'fmtstr-html-labels)) + +(defun hyperobject-class-fmtstr-xml-labels (obj) + (slot-value (portable-class-of obj) 'fmtstr-xml-labels)) + +(defun hyperobject-class-value-func (obj) + (slot-value (portable-class-of obj) 'value-func)) + +(defun hyperobject-class-xmlvalue-func (obj) + (slot-value (portable-class-of obj) 'xmlvalue-func)) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defun hyperobject-class-title (obj) + (awhen (slot-value (portable-class-of obj) 'title) + (if (consp it) + (car it) + it)))) + +(defun hyperobject-class-subobjects (obj) + (slot-value (portable-class-of obj) 'subobjects)) + +(defun hyperobject-class-references (obj) + (slot-value (portable-class-of obj) 'references)) + +(defun hyperobject-class-fields (obj) + (portable-class-slots (portable-class-of obj))) + +(defun hyperobject-class-fmtstr-html-ref (obj) + (slot-value (portable-class-of obj) 'fmtstr-html-ref)) + +(defun hyperobject-class-fmtstr-xml-ref (obj) + (slot-value (portable-class-of obj) 'fmtstr-xml-ref)) + +(defun hyperobject-class-fmtstr-html-ref-labels (obj) + (slot-value (portable-class-of obj) 'fmtstr-html-ref-labels)) + +(defun hyperobject-class-fmtstr-xml-ref-labels (obj) + (slot-value (portable-class-of obj) 'fmtstr-xml-ref-labels)) + +;;; Class name functions + +(defgeneric hyperobject-class-stdname (x)) +(defmethod hyperobject-class-stdname ((name string)) + (string-downcase (subseq name 1))) + +(defmethod hyperobject-class-stdname ((cl standard-object)) + (string-downcase (subseq (portable-class-name (portable-class-of cl)) 1))) + ;;;; Generic Print functions (defparameter *default-textformat* nil) @@ -412,7 +463,7 @@ (:null *default-nullformat*) (otherwise *default-textformat*))) -;;;; Output format classes for print hoes +;;;; Output format classes for print hyperobject-classes (defclass dataformat () ((file-start-str :type string :initarg :file-start-str :reader file-start-str) @@ -450,7 +501,7 @@ ()) (defun text-list-start-value-func (obj nitems) - (values (ho-title obj) nitems)) + (values (hyperobject-class-title obj) nitems)) (defclass textformat (dataformat) () @@ -458,14 +509,17 @@ :list-start-value-func #'text-list-start-value-func :list-start-indent t :obj-data-indent t - :obj-data-fmtstr #'ho-fmtstr-text - :obj-data-fmtstr-labels #'ho-fmtstr-text-labels + :obj-data-fmtstr #'hyperobject-class-fmtstr-text + :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-text-labels :obj-data-end-fmtstr "~%" - :obj-data-value-func #'ho-value-func)) + :obj-data-value-func #'hyperobject-class-value-func)) + +(defun class-name-of (obj) + (string-downcase (portable-class-name (portable-class-of obj)))) (defun htmlformat-list-start-value-func (x nitems) - (values (ho-title x) nitems (ho-name x))) + (values (hyperobject-class-title x) nitems (class-name-of x))) (defclass htmlformat (textformat) () @@ -484,9 +538,9 @@ :obj-end-fmtstr "~%" :obj-end-value-func #'identity :obj-data-indent t - :obj-data-fmtstr #'ho-fmtstr-html-labels - :obj-data-fmtstr-labels #'ho-fmtstr-html-labels - :obj-data-value-func #'ho-value-func)) + :obj-data-fmtstr #'hyperobject-class-fmtstr-html-labels + :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-html-labels + :obj-data-value-func #'hyperobject-class-value-func)) (defclass xhtmlformat (textformat) () @@ -505,16 +559,16 @@ :obj-end-fmtstr "~%" :obj-end-value-func #'identity :obj-data-indent t - :obj-data-fmtstr #'ho-fmtstr-html-labels - :obj-data-fmtstr-labels #'ho-fmtstr-html-labels - :obj-data-value-func #'ho-xml-value-func)) + :obj-data-fmtstr #'hyperobject-class-fmtstr-html-labels + :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-html-labels + :obj-data-value-func #'hyperobject-class-xmlvalue-func)) (defun xmlformat-list-end-value-func (x) - (format nil "~alist" (ho-name x))) + (format nil "~alist" (class-name-of x))) (defun xmlformat-list-start-value-func (x nitems) - (values (format nil "~alist" (ho-name x)) (ho-title x) nitems)) + (values (format nil "~alist" (class-name-of x)) (hyperobject-class-title x) nitems)) (defclass xmlformat (textformat) () @@ -526,15 +580,15 @@ :list-end-fmtstr "~%" :list-end-value-func #'xmlformat-list-end-value-func :obj-start-fmtstr "<~a>" - :obj-start-value-func #'ho-name + :obj-start-value-func #'class-name-of :obj-start-indent t :obj-end-fmtstr "~%" - :obj-end-value-func #'ho-name + :obj-end-value-func #'class-name-of :obj-end-indent nil :obj-data-indent nil - :obj-data-fmtstr #'ho-fmtstr-xml - :obj-data-fmtstr-labels #'ho-fmtstr-xml-labels - :obj-data-value-func #'ho-xml-value-func)) + :obj-data-fmtstr #'hyperobject-class-fmtstr-xml + :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-xml-labels + :obj-data-value-func #'hyperobject-class-xmlvalue-func)) (defclass link-ref () ((fmtstr :type function :initarg :fmtstr :accessor fmtstr) @@ -551,24 +605,24 @@ (defclass html-link-ref (link-ref) () - (:default-initargs :fmtstr #'ho-fmtstr-html-ref - :fmtstr-labels #'ho-fmtstr-html-ref-labels + (:default-initargs :fmtstr #'hyperobject-class-fmtstr-html-ref + :fmtstr-labels #'hyperobject-class-fmtstr-html-ref-labels :href-head "a href=" :href-end "a" :ampersand "&")) (defclass xhtml-link-ref (link-ref) () - (:default-initargs :fmtstr #'ho-fmtstr-html-ref - :fmtstr-labels #'ho-fmtstr-html-ref-labels + (:default-initargs :fmtstr #'hyperobject-class-fmtstr-html-ref + :fmtstr-labels #'hyperobject-class-fmtstr-html-ref-labels :href-head "a href=" :href-end "a" :ampersand "&")) (defclass xml-link-ref (link-ref) () - (:default-initargs :fmtstr #'ho-fmtstr-xml-ref - :fmtstr-labels #'ho-fmtstr-xml-ref-labels + (:default-initargs :fmtstr #'hyperobject-class-fmtstr-xml-ref + :fmtstr-labels #'hyperobject-class-fmtstr-xml-ref-labels :href-head "xmllink xlink:type=\"simple\" xlink:href=" :href-end "xmllink" :ampersand "&") @@ -706,11 +760,13 @@ (funcall (funcall (obj-data-value-func fmt) x) x)))) ;; make list of reference link fields for printing to refstr template - (dolist (ref (ho-references x)) + (dolist (ref (hyperobject-class-references x)) (let ((link-start (make-link-start x (link-ref fmt) (name ref) (lookup ref) - (nth (position (name ref) (ho-fields x) - :key #'(lambda (x) (name x))) + (nth (position (name ref) + (hyperobject-class-fields x) + :key #'(lambda (x) + (portable-slot-name x))) field-values) (append (link-parameters ref) refvars))) (link-end (make-link-end x (link-ref fmt) (name ref)))) @@ -751,9 +807,9 @@ (when objs (let ((objlist (mklist objs))) (dolist (obj objlist) - (awhen (ho-subobjects obj) ;; access list of functions - (dolist (subobj it) ;; for each child function - (awhen (funcall (reader subobj) obj) + (awhen (hyperobject-class-subobjects obj) ;; access list of functions + (dolist (child-obj it) ;; for each child function + (awhen (funcall (reader child-obj) obj) (load-all-subobjects it)))))) objs)) @@ -777,12 +833,12 @@ (fmt-obj-start obj fmt strm indent) (fmt-obj-data obj fmt strm (1+ indent) label refvars) (if subobjects - (awhen (ho-subobjects obj) ;; access list of functions - (dolist (subobj it) ;; for each child function - (awhen (funcall (reader subobj) obj) ;; access set of child objects - (print-hyperobject-class it fmt strm label - (1+ indent) english-only-function - subobjects refvars))))) + (awhen (hyperobject-class-subobjects obj) ;; access list of functions + (dolist (child-obj it) ;; for each child function + (awhen (funcall (reader child-obj) obj) ;; access set of child objects + (print-hyperobject-class it fmt strm label + (1+ indent) english-only-function + subobjects refvars))))) (fmt-obj-end obj fmt strm indent))) (fmt-list-end (car objs) fmt strm indent nobjs)) t)) @@ -803,11 +859,16 @@ objs) +(defclass hyperobject () + () + (:metaclass hyperobject-class)) + + (defmethod print-object ((obj hyperobject) (s stream)) (print-unreadable-object (obj s :type t :identity t) (let ((fmt (make-instance 'hyperobject::textformat))) (apply #'format - s (funcall (hyperobject::obj-data-fmtstr fmt) obj) + s (funcall (hyperobject-mop::obj-data-fmtstr fmt) obj) (multiple-value-list - (funcall (funcall (hyperobject::obj-data-value-func fmt) obj) obj)))))) + (funcall (funcall (hyperobject-mop::obj-data-value-func fmt) obj) obj)))))) diff --git a/mop-example.lisp b/mop-example.lisp deleted file mode 100644 index 278d4a7..0000000 --- a/mop-example.lisp +++ /dev/null @@ -1,80 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: hyperobject-example.lisp -;;;; Purpose: Hyperobject Example file -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Oct 2002 -;;;; -;;;; A simple example file for hyperobjects -;;;; -;;;; $Id: mop-example.lisp,v 1.2 2002/11/22 14:58:16 kevin Exp $ -;;;; -;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg -;;;; -;;;; ************************************************************************* - -(in-package :hyperobject-mop-user) - - -(defclass person (hyperobject) - ((first-name :type string :initarg :first-name :reader first-name :initform nil) - (last-name :type string :initarg :last-name :reader last-name :initform nil - :reference find-person-by-last-name) - (dob :type integer :initarg :dob :reader dob :initform 0 :format-func format-date) - (resume :type cdata :initarg :resume :reader resume) - (addresses :initarg :addresses :reader addresses :initform nil :subobject t)) - (:metaclass hyperobject-class) - (:title "Person")) - -(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 :type string :initarg :title :reader title :initform nil) - (street :type string :initarg :street :reader street :initform nil) - (phones :initarg :phones :reader phones :initform nil :subobject t)) - (:metaclass hyperobject-class) - (:title "Address")) - -(defclass phone (hyperobject) - ((phone-number :type string :initarg :phone-number :reader phone-number)) - (:metaclass hyperobject-class) - (:title "Phone Number")) - - -(defparameter home-phone-1 (make-instance 'phone :phone-number "367-9812")) -(defparameter home-phone-2 (make-instance 'phone :phone-number "367-9813")) - -(defparameter office-phone-1 (make-instance 'phone :phone-number "123-0001")) -(defparameter office-phone-2 (make-instance 'phone :phone-number "123-0002")) -(defparameter office-phone-3 (make-instance 'phone :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~%") -(print-hyperobject mary :subobjects t) - -(format t "~&XML Format with field labels and hyperlinks~%") -(print-hyperobject mary :subobjects t :label t :format :xmlref) diff --git a/no-mop-example.lisp b/no-mop-example.lisp new file mode 100644 index 0000000..c120c21 --- /dev/null +++ b/no-mop-example.lisp @@ -0,0 +1,80 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: hyperobject-plain-example.lisp +;;;; Purpose: Hyper Object Metaclass +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; This metaclass as functions to classes to allow display +;;;; in Text, HTML, and XML formats. This includes hyperlinking +;;;; capability and sub-objects. +;;;; +;;;; $Id: no-mop-example.lisp,v 1.1 2002/11/22 15:45:06 kevin Exp $ +;;;; +;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package :hyperobject-user) + +(define-hyperobject person () + ((first-name :type string :reference find-person-by-last-name) + (last-name :type string) + (dob :type integer :initform 0 :format-func format-date) + (resume :type cdata) + (addresses :subobject t)) + (:title "Person") + (:documentation "Person hyperobject class")) + +(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)))) + +(define-hyperobject address () + ((title :type string) + (street :type string) + (phones :subobject t)) + (:title "Address") + (:documentation "Address hyperobject")) + +(define-hyperobject phone () + ((phone-number :type string)) + (:title "Phone Number") + (:documentation "Phone hyperobject")) + + +(defparameter home-phone-1 (make-instance 'phone :phone-number "367-9812")) +(defparameter home-phone-2 (make-instance 'phone :phone-number "367-9813")) + +(defparameter office-phone-1 (make-instance 'phone :phone-number "123-0001")) +(defparameter office-phone-2 (make-instance 'phone :phone-number "123-0002")) +(defparameter office-phone-3 (make-instance 'phone :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~%") +(print-hyperobject mary :subobjects t) + +(format t "~&XML Format with field labels and hyperlinks~%") +(print-hyperobject mary :subobjects t :label t :format :xmlref) diff --git a/package.lisp b/package.lisp index 6c76fb9..61b19e9 100644 --- a/package.lisp +++ b/package.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: package.lisp,v 1.5 2002/11/22 10:49:24 kevin Exp $ +;;;; $Id: package.lisp,v 1.6 2002/11/22 15:43:22 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -16,10 +16,11 @@ (in-package :cl-user) -(defpackage #:hyperobject-mop +(defpackage #:hyperobject (:nicknames #:ho-mop) (:use #:common-lisp #:kmrcl) (:export + #:define-hyperobject #:hyperobject #:hyperobject-class #:hyperobject-base-url! @@ -28,8 +29,8 @@ #:print-hyperobject )) -(defpackage #:hyperobject - (:nicknames #:ho) +(defpackage #:hyperobject-no-mop + (:nicknames #:ho-no-mop) (:use #:common-lisp #:kmrcl) (:export #:define-hyperobject @@ -39,10 +40,13 @@ #:print-hyperobject )) -(defpackage #:hyperobject-mop-user - (:use #:hyperobject-mop #:cl #:cl-user)) - - (defpackage #:hyperobject-user + (:niceknames #:ho-user) (:use #:hyperobject #:cl #:cl-user)) +(defpackage #:hyperobject-no-mop-user + (:niceknames #:ho-no-mop-user) + (:use #:hyperobject-no-mop #:cl #:cl-user)) + + +