From 4bd7e3fad38f122bc3e1d93d523670fa124c73f0 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Fri, 22 Nov 2002 19:14:17 +0000 Subject: [PATCH] r3456: *** empty log message *** --- example.lisp | 9 +++-- hyperobject.lisp | 86 ++++++++++++++++++++++++++++-------------------- 2 files changed, 56 insertions(+), 39 deletions(-) diff --git a/example.lisp b/example.lisp index 9398cc6..cc9883d 100644 --- a/example.lisp +++ b/example.lisp @@ -9,7 +9,7 @@ ;;;; ;;;; A simple example file for hyperobjects ;;;; -;;;; $Id: example.lisp,v 1.2 2002/11/22 15:45:06 kevin Exp $ +;;;; $Id: example.lisp,v 1.3 2002/11/22 19:14:17 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -26,6 +26,7 @@ (resume :type cdata :initarg :resume :reader resume) (addresses :initarg :addresses :reader addresses :initform nil :subobject t)) (:metaclass hyperobject-class) + (:print-slots first-name last-name dob resume) (:title "Person")) (defun format-date (ut) @@ -45,12 +46,14 @@ (street :type string :initarg :street :reader street :initform nil) (phones :initarg :phones :reader phones :initform nil :subobject t)) (:metaclass hyperobject-class) - (:title "Address")) + (:title "Address") + (:print-slots title street)) (defclass phone (hyperobject) ((phone-number :type string :initarg :phone-number :reader phone-number)) (:metaclass hyperobject-class) - (:title "Phone Number")) + (:title "Phone Number") + (:print-slots phone-number)) (defparameter home-phone-1 (make-instance 'phone :phone-number "367-9812")) diff --git a/hyperobject.lisp b/hyperobject.lisp index 921f6f8..70b67b1 100644 --- a/hyperobject.lisp +++ b/hyperobject.lisp @@ -11,7 +11,7 @@ ;;;; in Text, HTML, and XML formats. This includes hyperlinking ;;;; capability and sub-objects. ;;;; -;;;; $Id: hyperobject.lisp,v 1.7 2002/11/22 16:05:08 kevin Exp $ +;;;; $Id: hyperobject.lisp,v 1.8 2002/11/22 19:14:17 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -79,35 +79,34 @@ ;; Main class (defclass hyperobject-class (standard-class) - ((title :initarg :title :type string :reader ml-std-title - :documentation -"Print Title for class") + ((title :initarg :title :type string :initform nil + :documentation "Print Title for class") + (print-slots :initarg :print-slots :type list :initform nil + :documentation "List of slots to print") (subobjects - :initarg :subobjects - :documentation -"List of fields that contain a list of subobjects objects.") + :initarg :subobjects :initform nil + :documentation "List of fields that contain a list of subobjects objects.") (references - :initarg :references :type list :reader ml-std-references + :initarg :references :type list :initform nil :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) + (value-func :initform nil :type function) + (xmlvalue-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) ) - (:default-initargs :title nil :subobjects nil :references nil) (:documentation "Metaclass for Markup Language classes.")) (defclass subobject () @@ -152,6 +151,14 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (list name (car value)) (list name `',value))) +#+lispworks +(defmethod clos:process-a-class-option ((class hyperobject-class) + (name (eql :print-slots)) + value) + (if (null (cdr value)) + (list name (car value)) + (list name `',value))) + (defmethod (compute-effective-slot-definition) :around ((cl hyperobject-class) #+(or allegro lispworks) slot dsds) (declare (ignorable slot)) @@ -189,7 +196,10 @@ Format is ((field-name field-lookup-func other-link-params) ...)") ho-type))) ;;;; Class initialization function - + +(defun find-slot-by-name (cl name) + (find name (class-slots cl) :key #'slot-definition-name)) + (defun init-hyperobject-class (cl) (let ((fmtstr-text "") (fmtstr-html "") @@ -209,18 +219,22 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (references nil) (subobjects nil)) (declare (ignore classname)) - (dolist (f (class-slots cl)) - (if (slot-value f 'subobject) - (push (make-instance 'subobject :name (slot-definition-name f) - :reader (if (eq t (esd-subobject f)) - (slot-definition-name f) - (esd-subobject f))) + + (dolist (slot-name (slot-value cl 'print-slots)) + (let ((slot (find-slot-by-name cl slot-name))) + (unless slot + (error "Slot ~A is not found in class ~S" slot-name cl)) + (if (slot-value slot 'subobject) + (push (make-instance 'subobject :name (slot-definition-name slot) + :reader (if (eq t (esd-subobject slot)) + (slot-definition-name slot) + (esd-subobject slot))) subobjects) - (let ((name (slot-definition-name f)) - (namestr (symbol-name (slot-definition-name f))) - (namestr-lower (string-downcase (symbol-name (slot-definition-name f)))) - (type (slot-value f 'ho-type)) - (formatter (slot-value f 'format-func)) + (let ((name (slot-definition-name slot)) + (namestr (symbol-name (slot-definition-name slot))) + (namestr-lower (string-downcase (symbol-name (slot-definition-name slot)))) + (type (slot-value slot 'ho-type)) + (formatter (slot-value slot 'format-func)) (value-fmt "~a") (plain-value-func nil) html-str xml-str html-label-str xml-label-str) @@ -260,13 +274,13 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (string-append fmtstr-html-labels html-label-str) (string-append fmtstr-xml-labels xml-label-str) - (if (esd-reference f) + (if (esd-reference slot) (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)) + (push (make-instance 'reference :name name :lookup (esd-reference slot)) references)) (progn (string-append fmtstr-html-ref html-str) @@ -284,7 +298,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (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) -- 2.34.1