From: Kevin M. Rosenberg Date: Fri, 13 Dec 2002 08:25:45 +0000 (+0000) Subject: r3615: *** empty log message *** X-Git-Tag: debian-2.11.0-2~230 X-Git-Url: http://git.kpe.io/?p=hyperobject.git;a=commitdiff_plain;h=a7f7ec44e3acd442817630a912b5a0c581e23538;ds=sidebyside r3615: *** empty log message *** --- diff --git a/base-class.lisp b/base-class.lisp index 0da829b..24c24a3 100644 --- a/base-class.lisp +++ b/base-class.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: base-class.lisp,v 1.3 2002/12/13 05:44:19 kevin Exp $ +;;;; $Id: base-class.lisp,v 1.4 2002/12/13 08:25:45 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -25,7 +25,7 @@ (defmethod print-object ((obj hyperobject) (s stream)) (print-unreadable-object (obj s :type t :identity t) (let ((view (get-category-view obj :compact-text))) - (apply #'format s (slot-value view 'obj-data-fmtstr) + (apply #'format s (obj-data-fmtstr view) (multiple-value-list - (funcall (slot-value view 'obj-data-value-func) obj)))))) + (funcall (obj-data-value-func view) obj)))))) diff --git a/mop.lisp b/mop.lisp index 1094c56..d1567ab 100644 --- a/mop.lisp +++ b/mop.lisp @@ -11,7 +11,7 @@ ;;;; in Text, HTML, and XML formats. This includes hyperlinking ;;;; capability and sub-objects. ;;;; -;;;; $Id: mop.lisp,v 1.10 2002/12/13 05:44:19 kevin Exp $ +;;;; $Id: mop.lisp,v 1.11 2002/12/13 08:25:45 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -27,24 +27,30 @@ (defclass hyperobject-class (standard-class) ( ;; slots initialized in defclass (user-name :initarg :user-name :type string :initform nil - :documentation "User name for class") + :accessor user-name + :documentation "User name for class") (default-print-slots :initarg :default-print-slots :type list :initform nil + :accessor default-print-slots :documentation "Defaults slots for a view") (description :initarg :description :initform nil + :accessor description :documentation "Class description") (version :initarg :version :initform nil - :documentation "Version number for class") + :accessor version + :documentation "Version number for class") (sql-name :initarg :table-name :initform nil) ;;; The remainder of these fields are calculated one time ;;; in finalize-inheritence. - (subobjects :initform nil :documentation + (subobjects :initform nil :accessor subobjects + :documentation "List of fields that contain a list of subobjects objects.") - (hyperlinks :type list :initform nil :documentation - "List of fields that have hyperlinks") - (class-id :type integer :initform nil :documentation - "Unique ID for the class") + (hyperlinks :type list :initform nil :accessor hyperlinks + :documentation "List of fields that have hyperlinks") + (class-id :type integer :initform nil + :accessor class-id + :documentation "Unique ID for the class") ;; SQL commands (create-table-cmd :initform nil :reader create-table-cmd) @@ -138,7 +144,11 @@ `(,(intern (symbol-name x)) :initarg ,(intern (symbol-name x) (symbol-name :keyword)) - :initform nil)) + :initform nil + :accessor + ,(intern (concatenate 'string + (symbol-name :dsd-) + (symbol-name x))))) *slot-options*)))) (eval `(defclass hyperobject-esd (standard-effective-slot-definition) @@ -146,8 +156,12 @@ `(,(intern (symbol-name x)) :initarg ,(intern (symbol-name x) (symbol-name :keyword)) - :initform nil)) - (append *slot-options* *slot-options-no-initarg*))))) + :initform nil + :accessor + ,(intern (concatenate 'string + (symbol-name :esd-) + (symbol-name x))))) + (append *slot-options* *slot-options-no-initarg*))))) ) ;; eval-when (defun intern-in-keyword (obj) @@ -163,13 +177,15 @@ (t obj))) -(defmethod compute-effective-slot-definition :around - ((cl hyperobject-class) #+(or allegro lispworks) name dsds) +(defmethod compute-effective-slot-definition :around ((cl hyperobject-class) + #+(or allegro lispworks) name + dsds) #+allergo (declare (ignore name)) (let* ((dsd (car dsds)) (ho-type (intern-in-keyword (slot-value dsd 'type))) (sql-type (ho-type-to-sql-type ho-type)) (length (when (consp ho-type) (cadr ho-type)))) + #+allergo (declare (ignore name)) (setf (slot-value dsd 'ho-type) ho-type) (setf (slot-value dsd 'sql-type) sql-type) (setf (slot-value dsd 'type) (ho-type-to-lisp-type ho-type)) @@ -257,10 +273,10 @@ (defun finalize-subobjects (cl) "Process class subobjects slot" - (setf (slot-value cl 'subobjects) + (setf (subobjects cl) (let ((subobjects '())) (dolist (slot (class-slots cl)) - (let-when (subobj-def (slot-value slot 'subobject)) + (let-when (subobj-def (esd-subobject slot)) (let ((subobject (make-instance 'subobject :name-class (class-name cl) :name-slot (slot-definition-name slot) @@ -293,13 +309,13 @@ (let ((*print-circle* nil)) (setf (documentation (class-name cl) 'class) (format nil "Hyperobject~A~A~A~A" - (aif (slot-value cl 'user-name) + (aif (user-name cl) (format nil ": ~A" it "")) - (aif (slot-value cl 'description) + (aif (description cl) (format nil "~%Class description: ~A" it) "") - (aif (slot-value cl 'subobjects) + (aif (subobjects cl) (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name-slot it)) "") - (aif (slot-value cl 'default-print-slots) + (aif (default-print-slots cl) (format nil "~%Default print slots:~{ ~A~}" it) "") )))) @@ -332,16 +348,16 @@ (find name (class-slots cl) :key #'slot-definition-name)) (defun hyperobject-class-user-name (obj) - (awhen (slot-value (class-of obj) 'user-name) + (awhen (user-name (class-of obj)) (if (consp it) (car it) it))) (defun hyperobject-class-subobjects (obj) - (slot-value (class-of obj) 'subobjects)) + (subobjects (class-of obj))) (defun hyperobject-class-hyperlinks (obj) - (slot-value (class-of obj) 'hyperlinks)) + (hyperlinks (class-of obj))) (defun hyperobject-class-fields (obj) (class-slots (class-of obj))) diff --git a/views.lisp b/views.lisp index c30c0a8..4d57aa4 100644 --- a/views.lisp +++ b/views.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: views.lisp,v 1.13 2002/12/13 07:33:54 kevin Exp $ +;;;; $Id: views.lisp,v 1.14 2002/12/13 08:25:45 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -20,11 +20,11 @@ (defclass object-view () - ((object-class :initform nil :initarg :object-class + ((object-class :initform nil :initarg :object-class :accessor object-class :documentation "Name of class for object to be viewed.") - (slots :initform nil :initarg :slots + (slots :initform nil :initarg :slots :accessor slots :documentation "List of effective slots for object to be viewed.") - (name :initform nil :initarg :name + (name :initform nil :initarg :name :accessor name :documentation "Name for this view.") (category :initform nil :initarg :category :reader category :documentation "Category for view. Helpful when want to find a view corresponding to a particular category.") @@ -33,36 +33,58 @@ (country-language :initform :en :initarg :country-language :documentation "Country's Language for this view.") ;; - (file-start-str :type string :initform nil :initarg :file-start-str) - (file-end-str :type string :initform nil :initarg :file-end-str) - (list-start-fmtstr :type string :initform nil :initarg :list-start-fmtstr) + (file-start-str :type string :initform nil :initarg :file-start-str + :accessor file-start-str) + (file-end-str :type string :initform nil :initarg :file-end-str + :accessor file-end-str) + (list-start-fmtstr :type string :initform nil :initarg :list-start-fmtstr + :accessor list-start-fmtstr) (list-start-value-func :type function :initform nil - :initarg :list-start-value-func) - (list-start-indent :initform nil :initarg :list-start-indent) - (list-end-fmtstr :type string :initform nil :initarg :list-end-fmtstr) + :initarg :list-start-value-func + :accessor list-start-value-func) + (list-start-indent :initform nil :initarg :list-start-indent + :accessor list-start-indent) + (list-end-fmtstr :type string :initform nil :initarg :list-end-fmtstr + :accessor list-end-fmtstr) (list-end-value-func :type function :initform nil - :initarg :list-end-value-func) - (list-end-indent :initform nil :initarg :list-end-indent) - (obj-start-fmtstr :type string :initform nil :initarg :obj-start-fmtstr) - (obj-start-value-func :initform nil :initarg :obj-start-value-func) - (obj-start-indent :initform nil :initarg :obj-start-indent) - (obj-end-fmtstr :type string :initform nil :initarg :obj-end-fmtstr) + :initarg :list-end-value-func + :accessor list-end-value-func) + (list-end-indent :initform nil :initarg :list-end-indent + :accessor list-end-indent) + (obj-start-fmtstr :type string :initform nil :initarg :obj-start-fmtstr + :accessor obj-start-fmtstr) + (obj-start-value-func :initform nil :initarg :obj-start-value-func + :accessor obj-start-value-func) + (obj-start-indent :initform nil :initarg :obj-start-indent + :accessor obj-start-indent) + (obj-end-fmtstr :type string :initform nil :initarg :obj-end-fmtstr + :accessor obj-end-fmtstr) (obj-end-value-func :type function :initform nil - :initarg :obj-end-value-func) - (obj-end-indent :initform nil :initarg :obj-end-indent) - (obj-data-indent :initform nil :initarg :obj-data-indent) - (obj-data-fmtstr :type string :initform nil :initarg :obj-data-fmtstr) + :initarg :obj-end-value-func + :accessor obj-end-value-func) + (obj-end-indent :initform nil :initarg :obj-end-indent + :accessor obj-end-indent) + (obj-data-indent :initform nil :initarg :obj-data-indent + :accessor obj-data-indent) + (obj-data-fmtstr :type string :initform nil :initarg :obj-data-fmtstr + :accessor obj-data-fmtstr) (obj-data-end-fmtstr :type string :initform nil - :initarg :obj-data-end-fmtstr) + :initarg :obj-data-end-fmtstr + :accessor obj-data-end-fmtstr) (obj-data-value-func :type function :initform nil - :initarg :obj-data-value-func) - + :initarg :obj-data-value-func + :accessor obj-data-value-func) (link-slots :type list :initform nil - :documentation "List of slot names that have hyperlinks") - (link-page-name :type string :initform nil :initarg :link-page-name) - (link-href-start :type string :initform nil :initarg :link-href-start) - (link-href-end :type string :initform nil :initarg :link-href-end) - (link-ampersand :type string :initform nil :initarg :link-ampersand)) + :documentation "List of slot names that have hyperlinks" + :accessor link-slots) + (link-page-name :type string :initform nil :initarg :link-page-name + :accessor link-page-name) + (link-href-start :type string :initform nil :initarg :link-href-start + :accessor link-href-start) + (link-href-end :type string :initform nil :initarg :link-href-end + :accessor link-href-end) + (link-ampersand :type string :initform nil :initarg :link-ampersand + :accessor link-ampersand)) (:default-initargs :link-page-name "disp-func1") (:documentation "View class for a hyperobject")) @@ -71,7 +93,7 @@ "Find or make a category view for an object" (let ((obj-class (class-of obj))) (if (null category) - (slot-value obj-class 'default-view) + (default-view obj-class) (aif (find category (views obj-class) :key #'category) it (let ((view @@ -87,20 +109,20 @@ (defun finalize-views (cl) "Finalize all views that are given on a objects initialization" - (unless (slot-value cl 'default-print-slots) - (setf (slot-value cl 'default-print-slots) + (unless (default-print-slots cl) + (setf (default-print-slots cl) (mapcar #'slot-definition-name (class-slots cl)))) (let ((views '())) - (dolist (view-def (slot-value cl 'views)) + (dolist (view-def (views cl)) (push (make-object-view cl view-def) views)) - (setf (slot-value cl 'views) (nreverse views))) + (setf (views cl) (nreverse views))) (cond ((default-view cl) - (setf (slot-value cl 'default-view) (make-object-view cl (default-view cl)))) + (setf (default-view cl) (make-object-view cl (default-view cl)))) ((car (views cl)) - (setf (slot-value cl 'default-view) (make-object-view cl (car (views cl))))) + (setf (default-view cl) (make-object-view cl (car (views cl))))) (t - (setf (slot-value cl 'default-view) (make-object-view cl :default))))) + (setf (default-view cl) (make-object-view cl :default))))) (defun make-object-view (cl view-def) "Make an object view from a definition. Do nothing if a class is passed so that reinitialization will be a no-op" @@ -120,7 +142,7 @@ (defmethod initialize-instance :after ((view object-view) &rest initargs &key &allow-other-keys) - (initialize-view (find-class (slot-value view 'object-class)) view)) + (initialize-view (find-class (object-class view)) view)) (defun initialize-view (obj-cl view) "Calculate all view slots for a hyperobject class" @@ -129,16 +151,16 @@ (value-func '()) (links '()) (category (category view))) - (unless (slot-value view 'slots) - (setf (slot-value view 'slots) (slot-value obj-cl 'default-print-slots))) - (dolist (slot-name (slot-value view 'slots)) + (unless (slots view) + (setf (slots view) (default-print-slots obj-cl))) + (dolist (slot-name (slots view)) (let ((slot (find-slot-by-name obj-cl slot-name))) (unless slot (error "Slot ~A is not found in class ~S" slot-name obj-cl)) (let ((name (slot-definition-name slot)) (namestr-lower (string-downcase (symbol-name (slot-definition-name slot)))) (type (slot-value slot 'type)) - (print-formatter (slot-value slot 'print-formatter))) + (print-formatter (esd-print-formatter slot))) (cond (first-field @@ -147,9 +169,6 @@ (t (string-append fmtstr " "))) - (when (slot-value slot 'hyperlink) - (push name links)) - (let ((value-fmt (case type ((or :integer :fixnum) @@ -174,23 +193,28 @@ (:xml-labels (string-append fmtstr (concatenate 'string " <" namestr-lower ">" value-fmt ""))) ((or :html-link :xhtml-link) - (if (slot-value slot 'hyperlink) + (push name links) + (if (esd-hyperlink slot) (string-append fmtstr "<~~a>" value-fmt "") (string-append fmtstr (concatenate 'string "" value-fmt "")))) (:xml-link - (if (slot-value slot 'hyperlink) + (push name links) + (if (esd-hyperlink slot) (string-append fmtstr "<~~a>" value-fmt "") (string-append fmtstr (concatenate 'string "<" namestr-lower ">" value-fmt "")))) (:html-link-labels - (if (slot-value slot 'hyperlink) + (push name links) + (if (esd-hyperlink slot) (string-append fmtstr "" namestr-lower " <~~a>" value-fmt "") (string-append fmtstr (concatenate 'string "" namestr-lower " " value-fmt "")))) (:xhtml-link-labels - (if (slot-value slot 'hyperlink) + (push name links) + (if (esd-hyperlink slot) (string-append fmtstr "<[!CDATA[" namestr-lower "]]> <~~a>" value-fmt "") (string-append fmtstr (concatenate 'string " " value-fmt "")))) (:xml-link-labels - (if (slot-value slot 'hyperlink) + (push name links) + (if (esd-hyperlink slot) (string-append fmtstr " <~~a>" value-fmt "") (string-append fmtstr (concatenate 'string " <" namestr-lower ">" value-fmt ""))))) ) ;; let value-fmt @@ -211,9 +235,9 @@ (setq value-func (compile nil (eval `(lambda (x) (values ,@(nreverse value-func))))))) - (setf (slot-value view 'obj-data-fmtstr) fmtstr) - (setf (slot-value view 'obj-data-value-func) value-func) - (setf (slot-value view 'link-slots) (nreverse links)) + (setf (obj-data-fmtstr view) fmtstr) + (setf (obj-data-value-func view) value-func) + (setf (link-slots view) (nreverse links)) (case category ((or :compact-text :compact-text-labels) @@ -224,25 +248,25 @@ (initialize-xml-view view)) ((or :html-link :html-link-labels) (initialize-html-view view) - (setf (slot-value view 'link-href-start) "a href=") - (setf (slot-value view 'link-href-end) "a") - (setf (slot-value view 'link-ampersand) "&")) + (setf (link-href-start view) "a href=") + (setf (link-href-end view) "a") + (setf (link-ampersand view) "&")) ((or :xhtml-link :xhtml-link-labels) (initialize-html-view view) - (setf (slot-value view 'link-href-start) "a href=") - (setf (slot-value view 'link-href-end) "a") - (setf (slot-value view 'link-ampersand) "&")) + (setf (link-href-start view) "a href=") + (setf (link-href-end view) "a") + (setf (link-ampersand view) "&")) ((or :xml-link :xml-link-labels) (initialize-xml-view view) - (setf (slot-value view 'link-href-start) + (setf (link-href-start view) "xmllink xlink:type=\"simple\" xlink:href=") - (setf (slot-value view 'link-href-end) "xmllink") - (setf (slot-value view 'link-ampersand) "&")) + (setf (link-href-end view) "xmllink") + (setf (link-ampersand view) "&")) ((or :ie-xml-link :ie-xml-link-labels) (initialize-xml-view view) - (setf (slot-value view 'link-href-start) "html:a href=") - (setf (slot-value view 'link-href-end) "html:a") - (setf (slot-value view 'link-ampersand) "&")))) + (setf (link-href-start view) "html:a href=") + (setf (link-href-end view) "html:a") + (setf (link-ampersand view) "&")))) view) @@ -260,52 +284,52 @@ (values (hyperobject-class-user-name x) nitems (class-name-of x))) (defun initialize-text-view (view) - (setf (slot-value view 'list-start-fmtstr) "~a~P:~%") - (setf (slot-value view 'list-start-value-func) #'text-list-start-value-func) - (setf (slot-value view 'list-start-indent) t) - (setf (slot-value view 'obj-data-indent) t) - (setf (slot-value view 'obj-data-end-fmtstr) (format nil "~%")) + (setf (list-start-fmtstr view) "~a~P:~%") + (setf (list-start-value-func view) #'text-list-start-value-func) + (setf (list-start-indent view) t) + (setf (obj-data-indent view) t) + (setf (obj-data-end-fmtstr view) (format nil "~%")) ) (defun initialize-html-view (view) (initialize-text-view view) - (setf (slot-value view 'file-start-str) (format nil "~%")) - (setf (slot-value view 'file-end-str) (format nil "~%")) - (setf (slot-value view 'list-start-indent) t) - (setf (slot-value view 'list-start-fmtstr) + (setf (file-start-str view) (format nil "~%")) + (setf (file-end-str view) (format nil "~%")) + (setf (list-start-indent view) t) + (setf (list-start-fmtstr view) "

~a~p:

~%")) - (setf (slot-value view 'list-end-indent) t) - (setf (slot-value view 'list-end-value-func) nil) - (setf (slot-value view 'obj-start-indent) t) - (setf (slot-value view 'obj-start-fmtstr) "
  • ") - (setf (slot-value view 'obj-start-value-func) nil) - (setf (slot-value view 'obj-end-indent) t) - (setf (slot-value view 'obj-end-fmtstr) (format nil "
    • ~%")) - (setf (slot-value view 'obj-end-value-func) nil) - (setf (slot-value view 'obj-data-indent) t)) + (setf (list-end-fmtstr view) (format nil "~%")) + (setf (list-end-indent view) t) + (setf (list-end-value-func view) nil) + (setf (obj-start-indent view) t) + (setf (obj-start-fmtstr view) "
  • ") + (setf (obj-start-value-func view) nil) + (setf (obj-end-indent view) t) + (setf (obj-end-fmtstr view) (format nil "
    • ~%")) + (setf (obj-end-value-func view) nil) + (setf (obj-data-indent view) t)) (defun initialize-xhtml-view (view) (initialize-text-view view) - (setf (slot-value view 'file-start-str) (format nil "~%")) - (setf (slot-value view 'file-end-str) (format nil "~%")) - (setf (slot-value view 'list-start-indent) t) - (setf (slot-value view 'list-start-fmtstr) + (setf (file-start-str view) (format nil "~%")) + (setf (file-end-str view) (format nil "~%")) + (setf (list-start-indent view) t) + (setf (list-start-fmtstr view) "

    ~a~p:

    ~%")) - (setf (slot-value view 'list-end-indent) t) - (setf (slot-value view 'list-end-value-func) nil) - (setf (slot-value view 'obj-start-indent) t) - (setf (slot-value view 'obj-start-fmtstr) "
  • ") - (setf (slot-value view 'obj-start-value-func) nil) - (setf (slot-value view 'obj-end-indent) t) - (setf (slot-value view 'obj-end-fmtstr) (format nil "
    • ~%")) - (setf (slot-value view 'obj-end-value-func) nil) - (setf (slot-value view 'obj-data-indent) t)) + (setf (list-end-fmtstr view) (format nil "~%")) + (setf (list-end-indent view) t) + (setf (list-end-value-func view) nil) + (setf (obj-start-indent view) t) + (setf (obj-start-fmtstr view) "
  • ") + (setf (obj-start-value-func view) nil) + (setf (obj-end-indent view) t) + (setf (obj-end-fmtstr view) (format nil "
    • ~%")) + (setf (obj-end-value-func view) nil) + (setf (obj-data-indent view) t)) (defun xmlformat-list-end-value-func (x) (format nil "~alist" (class-name-of x))) @@ -315,38 +339,38 @@ (defun initialize-xml-view (view) (initialize-text-view view) - (setf (slot-value view 'file-start-str) "") ; (std-xml-header) - (setf (slot-value view 'list-start-indent) t) - (setf (slot-value view 'list-start-fmtstr) "<~a>~a~p: ~%") - (setf (slot-value view 'list-start-value-func) + (setf (file-start-str view) "") ; (std-xml-header) + (setf (list-start-indent view) t) + (setf (list-start-fmtstr view) "<~a>~a~p: ~%") + (setf (list-start-value-func view) #'xmlformat-list-start-value-func) - (setf (slot-value view 'list-end-indent) t) - (setf (slot-value view 'list-end-fmtstr) "~%") - (setf (slot-value view 'list-end-value-func) #'xmlformat-list-end-value-func) - (setf (slot-value view 'obj-start-fmtstr) (format nil "<~(~a~)>" (slot-value view 'object-class))) - (setf (slot-value view 'obj-start-indent) t) - (setf (slot-value view 'obj-end-fmtstr) (format nil "~%" (slot-value view 'object-class))) - (setf (slot-value view 'obj-end-indent) nil) - (setf (slot-value view 'obj-data-indent) nil)) + (setf (list-end-indent view) t) + (setf (list-end-fmtstr view) "~%") + (setf (list-end-value-func view) #'xmlformat-list-end-value-func) + (setf (obj-start-fmtstr view) (format nil "<~(~a~)>" (object-class view))) + (setf (obj-start-indent view) t) + (setf (obj-end-fmtstr view) (format nil "~%" (object-class view))) + (setf (obj-end-indent view) nil) + (setf (obj-data-indent view) nil)) ;;; File Start and Ends (defun fmt-file-start (view strm) - (awhen (slot-value view 'file-start-str) + (awhen (file-start-str view) (write-string it strm))) (defun fmt-file-end (view strm) - (awhen (slot-value view 'file-end-str) + (awhen (file-end-str view) (write-string it strm))) ;;; List Start and Ends (defun fmt-list-start (obj view strm indent num-items) - (when (slot-value view 'list-start-indent) + (when (list-start-indent view) (indent-spaces indent strm)) - (let-when (fmtstr (slot-value view 'list-start-fmtstr)) - (let-if (value-func (slot-value view 'list-start-value-func)) + (let-when (fmtstr (list-start-fmtstr view)) + (let-if (value-func (list-start-value-func view)) (apply #'format strm fmtstr (multiple-value-list (funcall value-func obj num-items))) @@ -354,10 +378,10 @@ (defun fmt-list-end (obj view strm indent num-items) (declare (ignore num-items)) - (when (slot-value view 'list-end-indent) + (when (list-end-indent view) (indent-spaces indent strm)) - (let-when (fmtstr (slot-value view 'list-end-fmtstr)) - (let-if (value-func (slot-value view 'list-end-value-func)) + (let-when (fmtstr (list-end-fmtstr view)) + (let-if (value-func (list-end-value-func view)) (apply #'format strm fmtstr (multiple-value-list (funcall value-func obj))) (write-string fmtstr strm)))) @@ -365,19 +389,19 @@ ;;; Object Start and Ends (defun fmt-obj-start (obj view strm indent) - (when (slot-value view 'obj-start-indent) + (when (obj-start-indent view) (indent-spaces indent strm)) - (let-when (fmtstr (slot-value view 'obj-start-fmtstr)) - (let-if (value-func (slot-value view 'obj-start-value-func)) + (let-when (fmtstr (obj-start-fmtstr view)) + (let-if (value-func (obj-start-value-func view)) (apply #'format strm fmtstr (multiple-value-list (funcall value-func obj))) (write-string fmtstr strm)))) (defun fmt-obj-end (obj view strm indent) - (when (slot-value view 'obj-end-indent) + (when (obj-end-indent view) (indent-spaces indent strm)) - (let-when (fmtstr (slot-value view 'obj-end-fmtstr)) - (let-if (value-func (slot-value view 'obj-end-value-func)) + (let-when (fmtstr (obj-end-fmtstr view)) + (let-if (value-func (obj-end-value-func view)) (apply #'format strm fmtstr (multiple-value-list (funcall value-func obj))) (write-string fmtstr strm)))) @@ -386,15 +410,15 @@ (defun make-link-start (view fieldfunc fieldvalue refvars) (format nil "~a\"~a?func=~a~akey=~a~a\"" - (slot-value view 'link-href-start) - (make-url (slot-value view 'link-page-name)) + (link-href-start view) + (make-url (link-page-name view)) fieldfunc - (slot-value view 'link-ampersand) fieldvalue + (link-ampersand view) fieldvalue (if refvars (let ((varstr "")) (dolist (var refvars) (string-append - varstr (slot-value view 'ampersand) + varstr (link-ampersand view) (format nil "~a=~a" (car var) (cadr var)))) varstr) ""))) @@ -402,46 +426,46 @@ (defun make-link-end (obj view fieldname) (declare (ignore obj fieldname)) ;;(format nil "~a" (href-end ref)) - (slot-value view 'link-href-end) + (link-href-end view) ) (defun fmt-obj-data (obj view strm indent refvars) - (when (slot-value view 'obj-data-indent) + (when (obj-data-indent view) (indent-spaces indent strm)) - (if (slot-value view 'link-slots) + (if (link-slots view) (fmt-obj-data-with-link obj view strm refvars) (fmt-obj-data-plain obj view strm)) - (awhen (slot-value view 'obj-data-end-fmtstr) + (awhen (obj-data-end-fmtstr view) (format strm it))) (defun fmt-obj-data-plain (obj view strm) - (awhen (slot-value view 'obj-data-value-func) - (apply #'format strm (slot-value view 'obj-data-fmtstr) + (awhen (obj-data-value-func view) + (apply #'format strm (obj-data-fmtstr view) (multiple-value-list (funcall it obj))))) (defun fmt-obj-data-with-link (obj view strm refvars) (let ((refvalues '())) ;; make list of hyperlink link fields for printing to refstr template - (dolist (name (slot-value view 'link-slots)) - (let ((hyperlink - (find name (hyperobject-class-hyperlinks obj) :key #'name))) - (push (make-link-start view (lookup hyperlink) (slot-value obj name) - (append (link-parameters hyperlink) refvars)) - refvalues) - (push (make-link-end obj view name) refvalues))) + (dolist (name (link-slots view)) + (let-when (hyperlink + (find name (hyperobject-class-hyperlinks obj) :key #'name)) + (push (make-link-start view (lookup hyperlink) (slot-value obj name) + (append (link-parameters hyperlink) refvars)) + refvalues) + (push (make-link-end obj view name) refvalues))) (setq refvalues (nreverse refvalues)) (apply #'format strm (make-link-data-str obj view) refvalues))) (defun obj-data (obj view) "Returns the objects data as a string. Used by common-graphics outline function" - (awhen (slot-value view 'obj-data-value-func) - (apply #'format nil (funcall (slot-value view 'obj-data-fmtstr)) + (awhen (obj-data-value-func view) + (apply #'format nil (funcall (obj-data-fmtstr view)) (multiple-value-list (funcall it obj))))) (defun make-link-data-str (obj view) "Return fmt string for that contains ~a slots for hyperlink link start and end" - (awhen (slot-value view 'obj-data-value-func) - (apply #'format nil (slot-value view 'obj-data-fmtstr) + (awhen (obj-data-value-func view) + (apply #'format nil (obj-data-fmtstr view) (multiple-value-list (funcall it obj))))) ;;; Display method for objects