From: Kevin M. Rosenberg Date: Sun, 3 Nov 2002 19:59:10 +0000 (+0000) Subject: r3286: *** empty log message *** X-Git-Tag: debian-2.11.0-2~280 X-Git-Url: http://git.kpe.io/?p=hyperobject.git;a=commitdiff_plain;h=516272144b06d6a8a96a1a4f7b38bbaf410f2f14 r3286: *** empty log message *** --- 516272144b06d6a8a96a1a4f7b38bbaf410f2f14 diff --git a/COPYING b/COPYING new file mode 100644 index 0000000..6b3c2e0 --- /dev/null +++ b/COPYING @@ -0,0 +1,26 @@ +Copyright (c) 2000-2002 Kevin Rosenberg + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The name of the Authors may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR +BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/debian/README.Debian b/debian/README.Debian new file mode 100644 index 0000000..12bb47a --- /dev/null +++ b/debian/README.Debian @@ -0,0 +1,6 @@ +Installing hyperobject into your CL implementation that uses +Debian's Common Lisp Controller is easy. Just enter + +(require 'hyperobject) + +and a precompiled version of hyperobject should be loaded. diff --git a/debian/changelog b/debian/changelog new file mode 100644 index 0000000..ab46d98 --- /dev/null +++ b/debian/changelog @@ -0,0 +1,6 @@ +cl-hyperobject (1.0-1) unstable; urgency=low + + * Initial Release (closes: 167591) + + -- Kevin M. Rosenberg Sat, 5 Oct 2002 13:19:33 -0600 + diff --git a/debian/control b/debian/control new file mode 100644 index 0000000..7d76bfb --- /dev/null +++ b/debian/control @@ -0,0 +1,18 @@ +Source: cl-hyperobject +Section: devel +Priority: optional +Maintainer: Kevin M. Rosenberg +Build-Depends-Indep: debhelper (>= 4.0.0) +Standards-Version: 3.5.7.1 + +Package: cl-hyperobject +Architecture: all +Depends: ${shlibs:Depends}, common-lisp-controller +Description: Common Lisp library for hyperobject + This package contains a library for creating and display hyperobjects. + Hyperobjects contain references to subobjects as well as to linked + objects. This package includes functions to display hyperobjects in + multiple formats: ASCII Text, HTML, XML with optional field labels and + hyperlinks. + + diff --git a/debian/copyright b/debian/copyright new file mode 100644 index 0000000..ff56545 --- /dev/null +++ b/debian/copyright @@ -0,0 +1,33 @@ +This package was debianized by Kevin M. Rosenberg on +Nov 2, 2002. + +It was downloaded from ftp://ftp.b9.com/hyperobject/ +Upstream Author: Kevin M. Rosenberg + + +Copyright (c) 2000-2002 Kevin Rosenberg + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The name of the Authors may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/debian/postinst b/debian/postinst new file mode 100755 index 0000000..06ba81a --- /dev/null +++ b/debian/postinst @@ -0,0 +1,46 @@ +#! /bin/sh +# postinst script for cl-hyperobject +# +# see: dh_installdeb(1) + +set -e + +# package name according to lisp +LISP_PKG=hyperobject + +# summary of how this script can be called: +# * `configure' +# * `abort-upgrade' +# * `abort-remove' `in-favour' +# +# * `abort-deconfigure' `in-favour' +# `removing' +# +# for details, see http://www.debian.org/doc/debian-policy/ or +# the debian-policy package +# +# quoting from the policy: +# Any necessary prompting should almost always be confined to the +# post-installation script, and should be protected with a conditional +# so that unnecessary prompting doesn't happen if a package's +# installation fails and the `postinst' is called with `abort-upgrade', +# `abort-remove' or `abort-deconfigure'. + +case "$1" in + configure) + /usr/sbin/register-common-lisp-source ${LISP_PKG} + ;; + abort-upgrade|abort-remove|abort-deconfigure) + ;; + *) + echo "postinst called with unknown argument \`$1'" >&2 + exit 1 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 diff --git a/debian/prerm b/debian/prerm new file mode 100755 index 0000000..663c479 --- /dev/null +++ b/debian/prerm @@ -0,0 +1,42 @@ +#! /bin/sh +# prerm script for cl-hyperobject +# +# see: dh_installdeb(1) + +set -e + +# package name according to lisp +LISP_PKG=hyperobject + +# summary of how this script can be called: +# * `remove' +# * `upgrade' +# * `failed-upgrade' +# * `remove' `in-favour' +# * `deconfigure' `in-favour' +# `removing' +# +# for details, see http://www.debian.org/doc/debian-policy/ or +# the debian-policy package + + +case "$1" in + remove|upgrade|deconfigure) + /usr/sbin/unregister-common-lisp-source ${LISP_PKG} + ;; + failed-upgrade) + ;; + *) + echo "prerm called with unknown argument \`$1'" >&2 + exit 1 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 + + diff --git a/debian/rules b/debian/rules new file mode 100755 index 0000000..66e1069 --- /dev/null +++ b/debian/rules @@ -0,0 +1,82 @@ +#!/usr/bin/make -f + +export DH_COMPAT=4 + +pkg := hyperobject +debpkg := cl-hyperobject + + +clc-source := usr/share/common-lisp/source +clc-systems := usr/share/common-lisp/systems +clc-hyperobject := $(clc-source)/$(pkg) + +doc-dir := usr/share/doc/$(debpkg) + + +configure: configure-stamp +configure-stamp: + dh_testdir + # Add here commands to configure the package. + + touch configure-stamp + + +build: build-stamp + +build-stamp: configure-stamp + dh_testdir + # Add here commands to compile the package. + touch build-stamp + +clean: + dh_testdir + dh_testroot + rm -f build-stamp configure-stamp + # Add here commands to clean up after the build process. + rm -f debian/cl-hyperobject.postinst.* debian/cl-hyperobject.prerm.* + dh_clean + +install: build + dh_testdir + dh_testroot + dh_clean -k + # Add here commands to install the package into debian/hyperobject. + dh_installdirs $(clc-systems) $(clc-hyperobject) $(doc-dir) + dh_install hyperobject.asd $(shell echo *.lisp) $(clc-hyperobject) + dh_link $(clc-hyperobject)/hyperobject.asd $(clc-systems)/hyperobject.asd + +# Build architecture-independent files here. +binary-indep: build install + dh_testdir -i + dh_testroot -i +# dh_installdebconf + dh_installdocs -i +# dh_installexamples -i hyperobject-example.lisp +# dh_installmenu +# dh_installlogrotate +# dh_installemacsen +# dh_installpam +# dh_installmime +# dh_installinit +# dh_installcron +# dh_installman +# dh_installinfo +# dh_undocumented + dh_installchangelogs -i + dh_strip -i + dh_compress -i + dh_fixperms -i +# dh_makeshlibs + dh_installdeb -i +# dh_perl + dh_shlibdeps -i + dh_gencontrol -i + dh_md5sums -i + dh_builddeb -i + +# Build architecture-dependent files here. +binary-arch: build install + +binary: binary-indep binary-arch +.PHONY: build clean binary-indep binary-arch binary install configure + diff --git a/debian/upload.sh b/debian/upload.sh new file mode 100755 index 0000000..8818b94 --- /dev/null +++ b/debian/upload.sh @@ -0,0 +1,6 @@ +#!/bin/bash -e + +dup hyperobject -Uftp.med-info.com -D/home/ftp/hyperobject -su $* + + + diff --git a/hyperobject.asd b/hyperobject.asd new file mode 100644 index 0000000..50063cd --- /dev/null +++ b/hyperobject.asd @@ -0,0 +1,30 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: hyperobject.asd +;;;; Purpose: ASDF system definition for hyperobject package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id: hyperobject.asd,v 1.1 2002/11/03 19:59:10 kevin Exp $ +;;;; +;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg +;;;; ************************************************************************* + +(in-package :asdf) + +(defsystem :hyperobject + :perform (load-op :after (op hyperobject) + (pushnew :hyperobject cl:*features*)) + :components + ((:file "package") + (:file "hyperobject" :depends-on ("package"))) + :depends-on (:kmrcl)) + + +(when (ignore-errors (find-class 'load-compiled-op)) + (defmethod perform :after ((op load-compiled-op) + (c (eql (find-system :hyperobject)))) + (pushnew :hyperobject cl:*features*))) + diff --git a/hyperobject.lisp b/hyperobject.lisp new file mode 100644 index 0000000..37f27eb --- /dev/null +++ b/hyperobject.lisp @@ -0,0 +1,750 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: hyperobject.lisp +;;;; Purpose: Hyper Object Metaclass +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; This metaclass as functions to classes to allow display +;;;; in Text, HTML, and XML formats. This includes hyperlinking +;;;; capability and sub-objects. +;;;; +;;;; $Id: hyperobject.lisp,v 1.1 2002/11/03 19:59:10 kevin Exp $ +;;;; +;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package :hyperobject) + + +(eval-when (:compile-toplevel :execute) + (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))) + + +;; Utilities + +(defun my-class-of (obj) + #-(or cmu sbcl) (class-of obj) + #+sbcl (sb-pcl:class-of obj) + #+cmu (pcl:class-of obj)) + +(defun my-class-name (obj) + #-(or cmu sbcl) (class-name obj) + #+sbcl (sb-pcl:class-name obj) + #+cmu (pcl:class-name obj)) + +(defun xml-cdata (str) + (concatenate 'string "")) + +;; +(defclass ho-class (#-(or cmu sbcl) standard-class + #+cmu pcl::standard-class + #+sbcl sb-pcl::standard-class) + ((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 + :documentation +"List of fields that contain a list of subobjects objects.") + (ref-fields + :initarg :ref-fields :type list :reader ml-std-ref-field + :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) + ) + (:default-initargs :title nil :fields nil :subobjects-lists nil :ref-fields nil) + (:documentation "Metaclass for Markup Language classes.")) + +#+cmu +(defmethod pcl:finalize-inheritance :after ((cl ho-class)) + (init-ho-class cl)) + +#+scl +(defmethod clos:finalize-inheritance :after ((cl ho-class)) + (init-ho-class cl)) + + +#+sbcl +(defmethod sb-pcl:finalize-inheritance :after ((cl ho-class)) + (init-ho-class cl)) + + +#+cmu +(defmethod pcl:validate-superclass ((class ho-class) (superclass pcl::standard-class)) + t) + +#+scl +(defmethod clos:validate-superclass ((class ho-class) (superclass standard-class)) + t) + +#+sbcl +(defmethod sb-pcl:validate-superclass ((class ho-class) (superclass sb-pcl::standard-class)) + t) + +#+allegro +(defmethod mop:finalize-inheritance :after ((cl ho-class)) + (init-ho-class cl)) + +#+lispworks +(defmethod clos:finalize-inheritance :after ((cl ho-class)) + (init-ho-class cl)) + +#+lispworks +(defmethod clos:process-a-class-option ((class ho-class) + (name (eql :title)) + value) + (unless value + (error "ho-class title must have a value")) + (if (null (cdr value)) + (list name (car value)) + (list name `',value))) + +#+lispworks +(defmethod clos:process-a-class-option ((class ho-class) + (name (eql :fields)) + value) + (unless value + (error "ho-class fields must have a value")) + (list name `',value)) + +#+lispworks +(defmethod clos:process-a-class-option ((class ho-class) + (name (eql :ref-fields)) + value) + (unless value + (error "ho-class ref-fields must have a value")) + (list name `',value)) + +#+lispworks +(defmethod clos:process-a-class-option ((class ho-class) + (name (eql :subobjects-lists)) + value) + (unless value + (error "ho-class subobjects-lists must have a value")) + (list name `',value)) + +;;;; Class initialization function + +(defun init-ho-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 (my-class-name cl))) + (ref-fields (slot-value cl 'ref-fields))) + (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 "")) + + (string-append fmtstr-text value-fmt) + (string-append fmtstr-html html-str) + (string-append fmtstr-xml xml-str) + (string-append fmtstr-text-labels namestr-lower " " value-fmt) + (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 formatter + (setq plain-value-func + (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))) + )) + + (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 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)) + + +(defun ho-class-fmtstr-text (obj) + (slot-value (my-class-of obj) 'fmtstr-text)) + +(defun ho-class-fmtstr-html (obj) + (slot-value (my-class-of obj) 'fmtstr-html)) + +(defun ho-class-fmtstr-xml (obj) + (slot-value (my-class-of obj) 'fmtstr-xml)) + +(defun ho-class-fmtstr-text-labels (obj) + (slot-value (my-class-of obj) 'fmtstr-text-labels)) + +(defun ho-class-fmtstr-html-labels (obj) + (slot-value (my-class-of obj) 'fmtstr-html-labels)) + +(defun ho-class-fmtstr-xml-labels (obj) + (slot-value (my-class-of obj) 'fmtstr-xml-labels)) + +(defun ho-class-value-func (obj) + (slot-value (my-class-of obj) 'value-func)) + +(defun ho-class-xmlvalue-func (obj) + (slot-value (my-class-of obj) 'xmlvalue-func)) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defun ho-class-title (obj) + (awhen (slot-value (my-class-of obj) 'title) + (if (consp it) + (car it) + it)))) + +(defun ho-class-subobjects-lists (obj) + (slot-value (my-class-of obj) 'subobjects-lists)) + +(defun ho-class-ref-fields (obj) + (slot-value (my-class-of obj) 'ref-fields)) + +(defun ho-class-fields (obj) + (slot-value (my-class-of obj) 'fields)) + +(defun ho-class-fmtstr-html-ref (obj) + (slot-value (my-class-of obj) 'fmtstr-html-ref)) + +(defun ho-class-fmtstr-xml-ref (obj) + (slot-value (my-class-of obj) 'fmtstr-xml-ref)) + +(defun ho-class-fmtstr-html-ref-labels (obj) + (slot-value (my-class-of obj) 'fmtstr-html-ref-labels)) + +(defun ho-class-fmtstr-xml-ref-labels (obj) + (slot-value (my-class-of obj) 'fmtstr-xml-ref-labels)) + +;;; Class name functions + +(defgeneric ho-class-stdname (x)) +(defmethod ho-class-stdname ((name string)) + (string-downcase (subseq name 1))) + +(defmethod ho-class-stdname ((cl standard-object)) + (string-downcase (subseq (my-class-name (my-class-of cl)) 1))) + +;;;; Generic Print functions + +(defparameter *default-textformat* nil) +(defparameter *default-htmlformat* nil) +(defparameter *default-htmlrefformat* nil) +(defparameter *default-xhtmlformat* nil) +(defparameter *default-xhtmlrefformat* nil) +(defparameter *default-xmlformat* nil) +(defparameter *default-xmlrefformat* nil) +(defparameter *default-ie-xmlrefformat* nil) +(defparameter *default-nullformat* nil) +(defparameter *default-init-format?* nil) + +(defun make-format-instance (fmt) + (unless *default-init-format?* + (setq *default-textformat* (make-instance 'textformat)) + (setq *default-htmlformat* (make-instance 'htmlformat)) + (setq *default-htmlrefformat* (make-instance 'htmlrefformat)) + (setq *default-xhtmlformat* (make-instance 'xhtmlformat)) + (setq *default-xhtmlrefformat* (make-instance 'xhtmlrefformat)) + (setq *default-xmlformat* (make-instance 'xmlformat)) + (setq *default-xmlrefformat* (make-instance 'xmlrefformat)) + (setq *default-ie-xmlrefformat* (make-instance 'ie-xmlrefformat)) + (setq *default-nullformat* (make-instance 'nullformat)) + (setq *default-init-format?* t)) + + (case fmt + (:text *default-textformat*) + (:html *default-htmlformat*) + (:htmlref *default-htmlrefformat*) + (:xhtml *default-xhtmlformat*) + (:xhtmlref *default-xhtmlrefformat*) + (:xml *default-xmlformat*) + (:xmlref *default-xmlrefformat*) + (:ie-xmlref *default-ie-xmlrefformat*) + (:null *default-nullformat*) + (otherwise *default-textformat*))) + +;;;; Output format classes for print ho-classes + +(defclass dataformat () + ((file-start-str :type string :initarg :file-start-str :reader file-start-str) + (file-end-str :type string :initarg :file-end-str :reader file-end-str) + (list-start-fmtstr :type string :initarg :list-start-fmtstr :reader list-start-fmtstr) + (list-start-value-func :type function :initarg :list-start-value-func :reader list-start-value-func) + (list-start-indent :initarg :list-start-indent :reader list-start-indent) + (list-end-fmtstr :type string :initarg :list-end-fmtstr :reader list-end-fmtstr) + (list-end-value-func :type function :initarg :list-end-value-func :reader list-end-value-func) + (list-end-indent :initarg :list-end-indent :reader list-end-indent) + (obj-start-fmtstr :type string :initarg :obj-start-fmtstr :reader obj-start-fmtstr) + (obj-start-value-func :initarg :obj-start-value-func :reader obj-start-value-func) + (obj-start-indent :initarg :obj-start-indent :reader obj-start-indent) + (obj-end-fmtstr :type string :initarg :obj-end-fmtstr :reader obj-end-fmtstr) + (obj-end-value-func :initarg :obj-end-value-func :reader obj-end-value-func) + (obj-end-indent :initarg :obj-end-indent :reader obj-end-indent) + (obj-data-indent :initarg :obj-data-indent :reader obj-data-indent) + (obj-data-fmtstr :initarg :obj-data-fmtstr :reader obj-data-fmtstr) + (obj-data-fmtstr-labels :initarg :obj-data-fmtstr-labels :reader obj-data-fmtstr-labels) + (obj-data-end-fmtstr :initarg :obj-data-end-fmtstr :reader obj-data-end-fmtstr) + (obj-data-value-func :initarg :obj-data-value-func :reader obj-data-value-func) + (link-ref :initarg :link-ref :reader link-ref)) + (:default-initargs :file-start-str nil :file-end-str nil :list-start-fmtstr nil :list-start-value-func nil + :list-start-indent nil :list-end-fmtstr nil :list-end-value-func nil :list-end-indent nil + :obj-start-fmtstr nil :obj-start-value-func nil :obj-start-indent nil + :obj-end-fmtstr nil :obj-end-value-func nil :obj-end-indent nil + :obj-data-indent nil :obj-data-fmtstr nil :obj-data-fmtstr-labels nil :obj-data-end-fmtstr nil + :obj-data-value-func nil :link-ref nil) + (:documentation "Parent for all dataformat objects")) + +(defclass binaryformat (dataformat) + ()) + +(defclass nullformat (dataformat) + ()) + +(defun text-list-start-value-func (obj nitems) + (values (ho-class-title obj) nitems)) + +(defclass textformat (dataformat) + () + (:default-initargs :list-start-fmtstr "~a~P:~%" + :list-start-value-func #'text-list-start-value-func + :list-start-indent t + :obj-data-indent t + :obj-data-fmtstr #'ho-class-fmtstr-text + :obj-data-fmtstr-labels #'ho-class-fmtstr-text-labels + :obj-data-end-fmtstr "~%" + :obj-data-value-func #'ho-class-value-func)) + + +(defun class-name-of (obj) + (string-downcase (my-class-name (my-class-of obj)))) + +(defun htmlformat-list-start-value-func (x nitems) + (values (ho-class-title x) nitems (class-name-of x))) + +(defclass htmlformat (textformat) + () + (:default-initargs :file-start-str "~%" + :file-end-str "~%" + :list-start-indent t + :list-start-fmtstr "

~a~p:

    ~%" + :list-start-value-func #'htmlformat-list-start-value-func + :list-end-fmtstr "
~%" + :list-end-indent t + :list-end-value-func #'identity + :obj-start-indent t + :obj-start-fmtstr "
  • " + :obj-start-value-func #'identity + :obj-end-indent t + :obj-end-fmtstr "
    • ~%" + :obj-end-value-func #'identity + :obj-data-indent t + :obj-data-fmtstr #'ho-class-fmtstr-html-labels + :obj-data-fmtstr-labels #'ho-class-fmtstr-html-labels + :obj-data-value-func #'ho-class-value-func)) + +(defclass xhtmlformat (textformat) + () + (:default-initargs :file-start-str "~%" + :file-end-str "~%" + :list-start-indent t + :list-start-fmtstr "

    ~a~p:

      ~%" + :list-start-value-func #'htmlformat-list-start-value-func + :list-end-fmtstr "
    ~%" + :list-end-indent t + :list-end-value-func #'identity + :obj-start-indent t + :obj-start-fmtstr "
  • " + :obj-start-value-func #'identity + :obj-end-indent t + :obj-end-fmtstr "
    • ~%" + :obj-end-value-func #'identity + :obj-data-indent t + :obj-data-fmtstr #'ho-class-fmtstr-html-labels + :obj-data-fmtstr-labels #'ho-class-fmtstr-html-labels + :obj-data-value-func #'ho-class-xmlvalue-func)) + + +(defun xmlformat-list-end-value-func (x) + (format nil "~alist" (class-name-of x))) + +(defun xmlformat-list-start-value-func (x nitems) + (values (format nil "~alist" (class-name-of x)) (ho-class-title x) nitems)) + +(defclass xmlformat (textformat) + () + (:default-initargs :file-start-str "" ; (std-xml-header) + :list-start-indent t + :list-start-fmtstr "<~a>~a~p: ~%" + :list-start-value-func #'xmlformat-list-start-value-func + :list-end-indent t + :list-end-fmtstr "~%" + :list-end-value-func #'xmlformat-list-end-value-func + :obj-start-fmtstr "<~a>" + :obj-start-value-func #'class-name-of + :obj-start-indent t + :obj-end-fmtstr "~%" + :obj-end-value-func #'class-name-of + :obj-end-indent nil + :obj-data-indent nil + :obj-data-fmtstr #'ho-class-fmtstr-xml + :obj-data-fmtstr-labels #'ho-class-fmtstr-xml-labels + :obj-data-value-func #'ho-class-xmlvalue-func)) + +(defclass link-ref () + ((fmtstr :type function :initarg :fmtstr :accessor fmtstr) + (fmtstr-labels :type function :initarg :fmtstr-labels :accessor fmtstr-labels) + (page-name :type string :initarg :page-name :accessor page-name) + (href-head :type string :initarg :href-head :accessor href-head) + (href-end :type string :initarg :href-end :accessor href-end) + (ampersand :type string :initarg :ampersand :accessor ampersand)) + (:default-initargs :fmtstr nil + :fmtstr-labels nil + :page-name "disp-func1" + :href-head nil :href-end nil :ampersand nil) + (:documentation "Formatting for a linked reference")) + +(defclass html-link-ref (link-ref) + () + (:default-initargs :fmtstr #'ho-class-fmtstr-html-ref + :fmtstr-labels #'ho-class-fmtstr-html-ref-labels + :href-head "a href=" + :href-end "a" + :ampersand "&")) + +(defclass xhtml-link-ref (link-ref) + () + (:default-initargs :fmtstr #'ho-class-fmtstr-html-ref + :fmtstr-labels #'ho-class-fmtstr-html-ref-labels + :href-head "a href=" + :href-end "a" + :ampersand "&")) + +(defclass xml-link-ref (link-ref) + () + (:default-initargs :fmtstr #'ho-class-fmtstr-xml-ref + :fmtstr-labels #'ho-class-fmtstr-xml-ref-labels + :href-head "xmllink xlink:type=\"simple\" xlink:href=" + :href-end "xmllink" + :ampersand "&") + (:documentation "Mozilla's and W3's idea of a link with XML")) + +(defclass ie-xml-link-ref (xml-link-ref) + () + (:default-initargs :href-head "html:a href=" + :href-end "html:a" ) + (:documentation "Internet Explorer's idea of a link with XML")) + + +(defclass htmlrefformat (htmlformat) + () + (:default-initargs :link-ref (make-instance 'html-link-ref))) + +(defclass xhtmlrefformat (xhtmlformat) + () + (:default-initargs :link-ref (make-instance 'xhtml-link-ref))) + +(defclass xmlrefformat (xmlformat) + () + (:default-initargs :link-ref (make-instance 'xml-link-ref))) + +(defclass ie-xmlrefformat (xmlformat) + () + (:default-initargs :link-ref (make-instance 'ie-xml-link-ref))) + + +;;; File Start and Ends + +(defgeneric fmt-file-start (fmt s)) +(defmethod fmt-file-start ((fmt dataformat) (s stream))) + +(defmethod fmt-file-start ((fmt textformat) (s stream)) + (aif (file-start-str fmt) + (format s it))) + +(defgeneric fmt-file-end (fmt s)) +(defmethod fmt-file-end ((fmt textformat) (s stream)) + (aif (file-end-str fmt) + (format s it))) + +;;; List Start and Ends + +(defgeneric fmt-list-start (obj fmt s &optional indent num-items)) +(defmethod fmt-list-start (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1)) + (if (list-start-indent fmt) + (indent-spaces indent s)) + (aif (list-start-fmtstr fmt) + (apply #'format s it + (multiple-value-list + (funcall (list-start-value-func fmt) x num-items))))) + +(defgeneric fmt-list-end (obj fmt s &optional indent num-items)) +(defmethod fmt-list-end (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1)) + (declare (ignore num-items)) + (if (list-end-indent fmt) + (indent-spaces indent s)) + (aif (list-end-fmtstr fmt) + (apply #'format s it + (multiple-value-list + (funcall (list-end-value-func fmt) x))))) + +;;; Object Start and Ends + +(defgeneric fmt-obj-start (obj fmt s &optional indent)) +(defmethod fmt-obj-start (x (fmt textformat) (s stream) &optional (indent 0)) + (if (obj-start-indent fmt) + (indent-spaces indent s)) + (aif (obj-start-fmtstr fmt) + (apply #'format s it + (multiple-value-list + (funcall (obj-start-value-func fmt) x))))) + +(defgeneric fmt-obj-end (obj fmt s &optional indent)) +(defmethod fmt-obj-end (x (fmt textformat) (s stream) &optional (indent 0)) + (if (obj-end-indent fmt) + (indent-spaces indent s)) + (aif (obj-end-fmtstr fmt) + (apply #'format s it + (multiple-value-list + (funcall (obj-end-value-func fmt) x))))) + +;;; Object Data + +(defgeneric make-link-start (obj ref fieldname fieldfunc fieldvalue refvars)) +(defmethod make-link-start (obj (ref link-ref) fieldname fieldfunc fieldvalue refvars) + (declare (ignore obj fieldname)) + (format nil "~a\"~a?func=~a~akey=~a~a\"" + (href-head ref) (make-url (page-name ref)) fieldfunc + (ampersand ref) fieldvalue + (if refvars + (let ((varstr "")) + (dolist (var refvars) + (string-append varstr (format nil "~a~a=~a" + (ampersand ref) (car var) (cadr var)))) + varstr) + ""))) + +(defgeneric make-link-end (obj ref fieldname)) +(defmethod make-link-end (obj (ref link-ref) fieldname) + (declare (ignore obj fieldname)) + (format nil "~a" (href-end ref)) + ) + +(defgeneric fmt-obj-data (obj fmt s &optional indent label refvars)) +(defmethod fmt-obj-data (x (fmt textformat) s + &optional (indent 0) (label nil) (refvars nil)) + (if (obj-data-indent fmt) + (indent-spaces indent s)) + (if (link-ref fmt) + (fmt-obj-data-with-ref x fmt s label refvars) + (fmt-obj-data-plain x fmt s label)) + (aif (obj-data-end-fmtstr fmt) + (format s it))) + +(defgeneric fmt-obj-data-plain (obj fmt s label)) +(defmethod fmt-obj-data-plain (x (fmt textformat) s label) + (if label + (apply #'format s + (funcall (obj-data-fmtstr-labels fmt) x) + (multiple-value-list + (funcall (funcall (obj-data-value-func fmt) x) x))) + (apply #'format s (funcall (obj-data-fmtstr fmt) x) + (multiple-value-list + (funcall (funcall (obj-data-value-func fmt) x) x))))) + +(defgeneric fmt-obj-data-with-ref (obj fmt s label refvars)) +(defmethod fmt-obj-data-with-ref (x (fmt textformat) s label refvars) + (let ((refstr (make-ref-data-str x fmt label)) + (refvalues nil) + (field-values + (multiple-value-list + (funcall (funcall (obj-data-value-func fmt) x) x)))) + + ;; make list of reference link fields for printing to refstr template + (dolist (field (ho-class-ref-fields x)) + (let ((link-start + (make-link-start x (link-ref fmt) (car field) (cadr field) + (nth (position (car field) (ho-class-fields x) :key #'car) field-values) + (append (caddr field) refvars))) + (link-end (make-link-end x (link-ref fmt) (car field)))) + (push link-start refvalues) + (push link-end refvalues))) + (setq refvalues (nreverse refvalues)) + + (apply #'format s refstr refvalues))) + +(defgeneric obj-data (obj)) +(defmethod obj-data (x) + "Returns the objects data as a string. Used by common-graphics outline function" + (let ((fmt (make-format-instance :text))) + (apply #'format nil (funcall (obj-data-fmtstr fmt) x) + (multiple-value-list + (funcall (funcall (obj-data-value-func fmt) x) x))))) + +(defgeneric make-ref-data-str (obj fmt &optional label)) +(defmethod make-ref-data-str (x (fmt textformat) &optional (label nil)) + "Return fmt string for that contains ~a slots for reference link start and end" + (unless (link-ref fmt) + (error "fmt does not contain a link-ref")) + (let ((refstr + (if label + (apply #'format nil (funcall (fmtstr-labels (link-ref fmt)) x) + (multiple-value-list + (funcall (funcall (obj-data-value-func fmt) x) x))) + (apply #'format nil (funcall (fmtstr (link-ref fmt)) x) + (multiple-value-list (funcall (funcall (obj-data-value-func fmt) x) x)))))) + refstr)) + +;;; Display method for objects + + +(defgeneric load-all-subobjects (objs)) +(defmethod load-all-subobjects (objs) + "Load all subobjects if they have not already been loaded." + (when objs + (let ((objlist (mklist objs))) + (dolist (obj objlist) + (awhen (ho-class-subobjects-lists obj) ;; access list of functions + (dolist (child-obj it) ;; for each child function + (awhen (funcall (car child-obj) obj) + (load-all-subobjects it)))))) + objs)) + +(defgeneric output-ho-class (objs fmt strm + &optional label english-only-function + indent subobjects refvars)) + +(defmethod output-ho-class (objs (fmt dataformat) (strm stream) + &optional (label nil) (indent 0) + (english-only-function nil) + (subobjects nil) (refvars nil)) + "Display a single or list of ho-class instances and their subobjects" + (when objs + (setq objs (mklist objs)) + (let ((nobjs (length objs))) + (fmt-list-start (car objs) fmt strm indent nobjs) + (dolist (obj objs) + (unless (and english-only-function + (multiple-value-bind (eng term) (funcall english-only-function obj) + (and term (not eng)))) + (fmt-obj-start obj fmt strm indent) + (fmt-obj-data obj fmt strm (1+ indent) label refvars) + (if subobjects + (awhen (ho-class-subobjects-lists obj) ;; access list of functions + (dolist (child-obj it) ;; for each child function + (awhen (funcall (car child-obj) obj) ;; access set of child objects + (output-ho-class it fmt strm label + english-only-function + (1+ indent) subobjects refvars))))) + (fmt-obj-end obj fmt strm indent))) + (fmt-list-end (car objs) fmt strm indent nobjs)) + t)) + + +(defun print-ho (objs &key (os *standard-output*) (format :text) + (label nil) (english-only-function nil) + (subobjects nil) (file-wrapper t) (refvars nil)) + "EXPORTED Function: prints ho-class objects. Simplies call to output-ho-class" + (let ((fmt (make-format-instance format))) + (if file-wrapper + (fmt-file-start fmt os)) + (when objs + (output-ho-class objs fmt os label english-only-function 0 subobjects refvars)) + (if file-wrapper + (fmt-file-end fmt os))) + objs) diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..18acce7 --- /dev/null +++ b/package.lisp @@ -0,0 +1,28 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: package.lisp +;;;; Purpose: Package definition for hyperobject package +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2000 +;;;; +;;;; $Id: package.lisp,v 1.1 2002/11/03 19:59:10 kevin Exp $ +;;;; +;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) + +(in-package :cl-user) + +(defpackage #:hyperobject + (:use #:common-lisp) + (:export + #:ml-class + #:ml-class-title + #:load-all-subobjects + #:print-ho + )) + +