From 310528f335c81365343ca5503e4db4be062080a2 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sun, 24 Nov 2002 17:47:50 +0000 Subject: [PATCH] r3468: *** empty log message *** --- example.lisp | 26 +++-- hyperobject.lisp | 263 +++++++++++++++++++++++++---------------------- 2 files changed, 156 insertions(+), 133 deletions(-) diff --git a/example.lisp b/example.lisp index 39a884b..e16bba5 100644 --- a/example.lisp +++ b/example.lisp @@ -9,7 +9,7 @@ ;;;; ;;;; A simple example file for hyperobjects ;;;; -;;;; $Id: example.lisp,v 1.5 2002/11/23 18:41:45 kevin Exp $ +;;;; $Id: example.lisp,v 1.6 2002/11/24 17:47:50 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -28,7 +28,8 @@ (:metaclass hyperobject-class) (:default-initargs :first-name nil :last-name nil :dob 0 :resume nil) (:print-slots first-name last-name dob resume) - (:title "Person")) + (:title "Person") + (:description "A Person")) (defun format-date (ut) (when (typep ut 'integer) @@ -49,22 +50,25 @@ (:metaclass hyperobject-class) (:default-initargs :title nil :street nil) (:title "Address") - (:print-slots title street)) + (:print-slots title street) + (:description "An address")) (defclass phone (hyperobject) - ((phone-number :type string :initarg :phone-number :reader phone-number)) + ((title :type string :initarg :title :reader title) + (phone-number :type string :initarg :phone-number :reader phone-number)) (:metaclass hyperobject-class) (:title "Phone Number") - (:default-initargs :phone-number nil) - (:print-slots phone-number)) + (:default-initargs :title nil :phone-number nil) + (:print-slots title phone-number) + (:description "A 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 home-phone-1 (make-instance 'phone :title "Voice" :phone-number "367-9812")) +(defparameter home-phone-2 (make-instance 'phone :title "Fax" :phone-number "367-9813")) -(defparameter office-phone-1 (make-instance 'phone :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 office-phone-1 (make-instance 'phone :title "Main line" :phone-number "123-0001")) +(defparameter office-phone-2 (make-instance 'phone :title "Staff line" :phone-number "123-0002")) +(defparameter office-phone-3 (make-instance 'phone :title "Fax" :phone-number "123-0005")) (defparameter home (make-instance 'address :title "Home" :street "321 Shady Lane" :phones (list home-phone-1 home-phone-2))) diff --git a/hyperobject.lisp b/hyperobject.lisp index 454e57f..34a60a9 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.11 2002/11/23 22:19:17 kevin Exp $ +;;;; $Id: hyperobject.lisp,v 1.12 2002/11/24 17:47:50 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -54,10 +54,11 @@ (defclass hyperobject-dsd (standard-direct-slot-definition) - ((ho-type :initarg :ho-type :initform nil :accessor dsd-ho-type) - (print-formatter :initarg :print-formatter :initform nil :accessor dsd-print-formatter) - (subobject :initarg :subobject :initform nil :accessor dsd-subobject) - (reference :initarg :reference :initform nil :accessor dsd-reference) + ((ho-type :initarg :ho-type :initform nil) + (print-formatter :initarg :print-formatter :initform nil) + (subobject :initarg :subobject :initform nil) + (reference :initarg :reference :initform nil) + (description :initarg :reference :initform nil) )) (defclass hyperobject-esd (standard-effective-slot-definition) @@ -65,26 +66,28 @@ (print-formatter :initarg :print-formatter :initform nil :accessor esd-print-formatter) (subobject :initarg :subobject :initform nil :accessor esd-subobject) (reference :initarg :reference :initform nil :accessor esd-reference) + (description :initarg :reference :initform nil :accessor esd-description) )) ;; Main class (defclass hyperobject-class (standard-class) - ((title :initarg :title :type string :initform nil + ( ;; slots initialized in defclass + (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 :initform nil - :documentation "List of fields that contain a list of subobjects objects.") - (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) ...)") - + :documentation "List of slots to print") + (description :initarg :description :initform nil + :documentation "Class description") + ;;; The remainder of these fields are calculated one time ;;; in finalize-inheritence. + + (subobjects :initform nil :documentation + "List of fields that contain a list of subobjects objects.") + (references :type list :initform nil :documentation + "List of fields that have references") + (value-func :initform nil :type function) (xmlvalue-func :initform nil :type function) (fmtstr-text :initform nil :type string) @@ -131,24 +134,22 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (find-class 'hyperobject-dsd)) +(defmacro define-class-slot (slot-name &optional required) + #+lispworks + (defmethod clos:process-a-class-option ((class hyperobject-class) + (name (eql ,slot-name)) + value) + (when (and ,required (null value)) + (error "hyperobject class slot ~A must have a value" name)) + (if (null (cdr value)) + (list name (car value)) + (list name `',value))) + ) -#+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))) +(define-class-slot :title) +(define-class-slot :print-slots) +(define-class-slot :description) -#+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) @@ -165,6 +166,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") :print-formatter (slot-value dsd 'print-formatter) :subobject (slot-value dsd 'subobject) :reference (slot-value dsd 'reference) + :description (slot-value dsd 'description) ia))) ) @@ -190,72 +192,84 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (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 "") - (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 (class-name cl)) - (package (symbol-package (class-name cl))) - (references nil) - (subobjects nil)) - (declare (ignore classname)) - (dolist (slot (class-slots cl)) - (when (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))) - (setf (slot-value cl 'subobjects) subobjects) - (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)) - (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)) - (print-formatter (slot-value slot 'print-formatter)) - (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 :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 "")) - + + +(defun process-subobjects (cl) + "Process class subobjects slot" + (dolist (slot (class-slots cl)) + (when (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))) + (setf (slot-value cl 'subobjects) subobjects)) + +(defun process-documentation (cl) + "Calculate class documentation slot" + (setf (slot-value cl 'documentation) + (format nil "Hyperobject class: ~A" (slot-value cl 'description))) + ) + + +(defun process-views (cl) + "Calculate all view slots for a hyperobject class" + (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 (class-name cl)) + (package (symbol-package (class-name cl))) + (references nil) + (subobjects nil)) + (declare (ignore classname)) + (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)) + (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)) + (print-formatter (slot-value slot 'print-formatter)) + (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 :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) @@ -288,33 +302,38 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (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) - - (if value-func - (setq value-func `(lambda (x) (values ,@value-func))) + + (setf (slot-value cl 'references) references) + + (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 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)) + (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 init-hyperobject-class (cl) + "Initialize a hyperobject class. Calculates all class slots" + (process-subobjects cl) + (process-documentation cl) + (process-views cl)) (defun hyperobject-class-fmtstr-text (obj) (slot-value (class-of obj) 'fmtstr-text)) -- 2.34.1