From c3f7ae77695d2e8ab2378890c10eaf09b0021dfc Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Fri, 22 Nov 2002 14:58:16 +0000 Subject: [PATCH] r3453: *** empty log message *** --- hyperobject-mop.lisp | 245 +++++++++++++++++++++++-------------------- mop-example.lisp | 36 +++---- 2 files changed, 145 insertions(+), 136 deletions(-) diff --git a/hyperobject-mop.lisp b/hyperobject-mop.lisp index affddc8..9f3113a 100644 --- a/hyperobject-mop.lisp +++ b/hyperobject-mop.lisp @@ -11,7 +11,7 @@ ;;;; in Text, HTML, and XML formats. This includes hyperlinking ;;;; capability and sub-objects. ;;;; -;;;; $Id: hyperobject-mop.lisp,v 1.2 2002/11/22 12:16:03 kevin Exp $ +;;;; $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 ;;;; @@ -36,6 +36,18 @@ #+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 @@ -47,9 +59,9 @@ #+(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) - (format-func :initarg :format-func :initform nil :accessor dsd-format-func) )) (defclass hyperobject-esd (#+allegro mop::standard-effective-slot-definition @@ -58,9 +70,9 @@ #+(or scl cmucl) pcl::standard-effective-slot-definition ) ((ho-type :initarg :ho-type :initform nil :accessor esd-ho-type) - (suboject :initarg :subobject :initform nil :accessor esd-subobject) - (reference :initarg :reference :initform nil :accessor esd-reference) (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 @@ -71,16 +83,12 @@ ((title :initarg :title :type string :reader ml-std-title :documentation "Print Title for class") - (fields :initarg :fields :reader ml-std-fields - :documentation -"List of field lists for printing. Format is - ((fieldname type optional-formatter) ... )") - (subobjects-lists - :initarg :subobjects-lists :reader ml-std-subobjects-lists + (subobjects + :initarg :subobjects :documentation "List of fields that contain a list of subobjects objects.") - (ref-fields - :initarg :ref-fields :type list :reader ml-std-ref-field + (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) ...)") @@ -100,9 +108,26 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (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 :fields nil :subobjects-lists nil :ref-fields nil) + (: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)) @@ -169,37 +194,12 @@ 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 :fields)) - value) - (unless value - (error "hyperobject-class fields must have a value")) - (list name `',value)) - -#+lispworks -(defmethod clos:process-a-class-option ((class hyperobject-class) - (name (eql :ref-fields)) - value) - (unless value - (error "hyperobject-class ref-fields must have a value")) - (list name `',value)) - -#+lispworks -(defmethod clos:process-a-class-option ((class hyperobject-class) - (name (eql :subobjects-lists)) - value) - (unless value - (error "hyperobject-class subobjects-lists must have a 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) slot dsds) + :around ((cl hyperobject-class) #+(or allegro lispworks) slot dsds) (declare (ignorable slot)) (let* ((dsd (car dsds)) (ho-type (slot-value dsd 'type))) @@ -208,12 +208,15 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (let ((ia #+allegro (excl::compute-effective-slot-definition-initargs cl dsds) #+lispworks (clos::compute-effective-slot-definition-initargs cl slot dsds) - #+sbcl (sb-cl::compute-effective-slot-definition-initargs cl slot dsds) - #+(or cmucl scl) (pcl::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))) ) @@ -251,48 +254,55 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (first-field t) (value-func '()) (xmlvalue-func '()) - (classname (class-name cl)) + (classname (portable-class-name cl)) (package (symbol-package (portable-class-name cl))) - (ref-fields (slot-value cl 'ref-fields))) + (references nil) + (subobjects nil)) (declare (ignore classname)) - (dolist (f (slot-value cl 'fields)) - (let ((name (car f)) - (namestr (symbol-name (car f))) - (namestr-lower (string-downcase (symbol-name (car f)))) - (type (cadr f)) - (formatter (caddr f)) - (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 "")) - + (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) @@ -300,29 +310,34 @@ 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 (find name ref-fields :key #'car) - (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 (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)))) + (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))) - )) + (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))) @@ -380,14 +395,14 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (car it) it)))) -(defun hyperobject-class-subobjects-lists (obj) - (slot-value (portable-class-of obj) 'subobjects-lists)) +(defun hyperobject-class-subobjects (obj) + (slot-value (portable-class-of obj) 'subobjects)) -(defun hyperobject-class-ref-fields (obj) - (slot-value (portable-class-of obj) 'ref-fields)) +(defun hyperobject-class-references (obj) + (slot-value (portable-class-of obj) 'references)) (defun hyperobject-class-fields (obj) - (slot-value (portable-class-of obj) 'fields)) + (portable-class-slots (portable-class-of obj))) (defun hyperobject-class-fmtstr-html-ref (obj) (slot-value (portable-class-of obj) 'fmtstr-html-ref)) @@ -745,12 +760,16 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (funcall (funcall (obj-data-value-func fmt) x) x)))) ;; make list of reference link fields for printing to refstr template - (dolist (field (hyperobject-class-ref-fields x)) + (dolist (ref (hyperobject-class-references x)) (let ((link-start - (make-link-start x (link-ref fmt) (car field) (cadr field) - (nth (position (car field) (hyperobject-class-fields x) :key #'car) field-values) - (append (caddr field) refvars))) - (link-end (make-link-end x (link-ref fmt) (car field)))) + (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)) @@ -788,9 +807,9 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (when objs (let ((objlist (mklist objs))) (dolist (obj objlist) - (awhen (hyperobject-class-subobjects-lists obj) ;; access list of functions + (awhen (hyperobject-class-subobjects obj) ;; access list of functions (dolist (child-obj it) ;; for each child function - (awhen (funcall (car child-obj) obj) + (awhen (funcall (reader child-obj) obj) (load-all-subobjects it)))))) objs)) @@ -814,9 +833,9 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (fmt-obj-start obj fmt strm indent) (fmt-obj-data obj fmt strm (1+ indent) label refvars) (if subobjects - (awhen (hyperobject-class-subobjects-lists obj) ;; access list of functions + (awhen (hyperobject-class-subobjects obj) ;; access list of functions (dolist (child-obj it) ;; for each child function - (awhen (funcall (car child-obj) obj) ;; access set of child objects + (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))))) @@ -849,7 +868,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (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 index ce275d5..278d4a7 100644 --- a/mop-example.lisp +++ b/mop-example.lisp @@ -9,7 +9,7 @@ ;;;; ;;;; A simple example file for hyperobjects ;;;; -;;;; $Id: mop-example.lisp,v 1.1 2002/11/22 10:49:24 kevin Exp $ +;;;; $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 ;;;; @@ -19,19 +19,14 @@ (defclass person (hyperobject) - ((first-name :type string :initarg :first-name :reader first-name) - (last-name :type string :initarg :last-name :reader last-name) - (dob :type integer :initarg :dob :reader dob) - (resume :initarg :resume :reader resume) - (addresses :initarg :addresses :reader addresses)) + ((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) - (:default-initargs - :first-name nil :last-name nil :resume nil :dob 0 :addresses nil) - (:title "Person") - (:subobjects-lists (addresses address)) - (:fields (first-name :string) (last-name :string) (dob :integer format-date) - (resume :cdata)) - (:ref-fields (last-name find-person-by-last-name))) + (:title "Person")) (defun format-date (ut) (when (typep ut 'integer) @@ -46,21 +41,16 @@ hr min sec)))) (defclass address (hyperobject) - ((title :type string :initarg :title :reader title) - (street :type string :initarg :street :reader street) - (phones :initarg :phones :reader phones)) + ((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) - (:default-initargs :title nil :street nil :phones nil) - (:title "Address") - (:subobjects-lists (phones phone)) - (:fields (title :string) (street :string))) - + (:title "Address")) (defclass phone (hyperobject) ((phone-number :type string :initarg :phone-number :reader phone-number)) (:metaclass hyperobject-class) - (:title "Phone Number") - (:fields (phone-number :string))) + (:title "Phone Number")) (defparameter home-phone-1 (make-instance 'phone :phone-number "367-9812")) -- 2.34.1