X-Git-Url: http://git.kpe.io/?p=hyperobject.git;a=blobdiff_plain;f=views.lisp;h=607e0d2a440614bf8def35f9270189e9bb9c81f1;hp=dfd6aaa6332190f72d336c683c7330bb50a2a92d;hb=19cb24908d2ba2faec3afbdd180eed0c7d7d8515;hpb=4e78f4f0086c35ac3fd4459e3fff1186d13bc07f diff --git a/views.lisp b/views.lisp index dfd6aaa..607e0d2 100644 --- a/views.lisp +++ b/views.lisp @@ -7,15 +7,12 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: views.lisp,v 1.49 2003/05/30 18:46:35 kevin Exp $ +;;;; $Id: views.lisp,v 1.54 2003/06/12 16:37:44 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* -(in-package :hyperobject) - -(eval-when (:compile-toplevel :execute) - (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2)))) +(in-package #:hyperobject) (defclass object-view () @@ -72,15 +69,16 @@ (link-slots :type list :initform nil :documentation "List of slot names that have hyperlinks" :accessor link-slots) - (link-page-name :type (or string null) :initform nil :initarg :link-page-name - :accessor link-page-name) + (link-page :type (or string null) :initform nil + :initarg :link-page + :accessor link-page) (link-href-start :type (or string null) :initform nil :initarg :link-href-start :accessor link-href-start) (link-href-end :type (or string null) :initform nil :initarg :link-href-end :accessor link-href-end) (link-ampersand :type (or string null) :initform nil :initarg :link-ampersand :accessor link-ampersand)) - (:default-initargs :link-page-name "disp-func1") + (:default-initargs :link-page "disp-func1") (:documentation "View class for a hyperobject")) @@ -514,32 +512,37 @@ ;;; Object Data -(defun make-link-start (view fieldfunc fieldvalue refvars) +(defun make-link-start (view fieldfunc fieldvalue refvars link-printer) (with-output-to-string (s) (write-string (link-href-start view) s) (write-char #\" s) - (write-string (make-url (link-page-name view)) s) - (write-string "?func=" s) - (write-simple fieldfunc s) - (write-string (link-ampersand view) s) - (write-string "key=" s) - (write-simple fieldvalue s) - (dolist (var refvars) - (write-string (link-ampersand view) s) - (write-simple (car var) s) - (write-char #\= s) - (write-simple (cdr var) s)) + (let ((link-page (link-page view))) + (cond + ((null link-printer) + (write-string (make-url link-page) s) + (write-string "?func=" s) + (write-simple fieldfunc s) + (write-string (link-ampersand view) s) + (write-string "key=" s) + (write-simple fieldvalue s) + (dolist (var refvars) + (write-string (link-ampersand view) s) + (write-simple (car var) s) + (write-char #\= s) + (write-simple (cdr var) s))) + (link-printer + (funcall link-printer link-page fieldfunc fieldvalue refvars s)))) (write-char #\" s))) (defun make-link-end (obj view fieldname) (declare (ignore obj fieldname)) (link-href-end view)) -(defun fmt-obj-data (obj view strm indent refvars) +(defun fmt-obj-data (obj view strm indent refvars link-printer) (when (obj-data-indent view) (indent-spaces indent strm)) (if (link-slots view) - (fmt-obj-data-with-link obj view strm refvars) + (fmt-obj-data-with-link obj view strm refvars link-printer) (fmt-obj-data-plain obj view strm)) (awhen (obj-data-end-str view) (write-string it strm))) @@ -548,13 +551,15 @@ (awhen (obj-data-printer view) (funcall it obj strm nil))) -(defun fmt-obj-data-with-link (obj view strm refvars) +(defun fmt-obj-data-with-link (obj view strm refvars link-printer) (let ((refvalues '())) + (declare (dynamic-extent refvalues)) ;; make list of hyperlink link fields for printing to refstr template (dolist (name (link-slots view)) (awhen (find name (hyperobject-class-hyperlinks obj) :key #'name) (push (make-link-start view (lookup it) (slot-value obj name) - (append (link-parameters it) refvars)) + (append (link-parameters it) refvars) + link-printer) refvalues) (push (make-link-end obj view name) refvalues))) (funcall (obj-data-printer view) obj strm (nreverse refvalues)))) @@ -575,9 +580,8 @@ objs) (defun view-hyperobject (objs view category strm &optional (indent 0) filter - subobjects refvars) + subobjects refvars link-printer) "Display a single or list of hyperobject-class instances and their subobjects" - (declare (fixnum indent)) (let-when (objlist (mklist objs)) (let ((nobjs (length objlist)) (*print-pretty* nil) @@ -590,21 +594,23 @@ (dolist (obj objlist) (unless (and filter (not (funcall filter obj))) (fmt-obj-start obj view strm indent) - (fmt-obj-data obj view strm (1+ indent) refvars) + (fmt-obj-data obj view strm (1+ indent) refvars link-printer) (when (and subobjects (hyperobject-class-subobjects obj)) (dolist (subobj (hyperobject-class-subobjects obj)) (aif (slot-value obj (name-slot subobj)) - (view-hyperobject it (get-category-view (car (mklist it)) category) + (view-hyperobject it + (get-category-view (car (mklist it)) + category) category strm (1+ indent) filter - subobjects refvars)))) + subobjects refvars link-printer)))) (fmt-obj-end obj view strm indent))) (fmt-list-end (car objlist) view strm indent nobjs))) objs) (defun view (objs &key (stream *standard-output*) category view - filter subobjects refvars file-wrapper) - "EXPORTED Function: prints hyperobject-class objects. Simplies call to view-hyperobject" + filter subobjects refvars file-wrapper link-printer) + "EXPORTED Function: prints hyperobject-class objects. Calls view-hyperobject" (let-when (objlist (mklist objs)) (when category (setq view (get-category-view (car objlist) category))) @@ -612,7 +618,8 @@ (setq view (default-view (class-of (car objlist))))) (when file-wrapper (fmt-file-start view stream)) - (view-hyperobject objlist view category stream 0 filter subobjects refvars) + (view-hyperobject objlist view category stream 0 filter subobjects refvars + link-printer) (when file-wrapper (fmt-file-end view stream))) objs)