cl-hyperobject-2.12.0/0000755000175000017500000000000011605662442013526 5ustar kevinkevincl-hyperobject-2.12.0/COPYING0000644000175000017500000000261510667175450014572 0ustar kevinkevinCopyright (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. cl-hyperobject-2.12.0/Makefile0000644000175000017500000000115010667175450015170 0ustar kevinkevin.PHONY: all clean test test-acl test-sbcl test-file:=`pwd`/run-tests.lisp all: clean: @find . -type f -name "*.fasl*" -or -name "*.ufsl" -or -name "*.x86f" \ -or -name "*.fas" -or -name "*.pfsl" -or -name "*.dfsl" \ -or -name "*~" -or -name ".#*" -or -name "#*#" | xargs rm -f test: test-alisp test-alisp: alisp8 -q -L $(test-file) test-mlisp: mlisp -q -L $(test-file) test-sbcl: sbcl --noinform --disable-debugger --userinit $(test-file) test-cmucl: lisp -init $(test-file) test-lw: lw-console -init $(test-file) test-scl: scl -init $(test-file) test-clisp: clisp -norc -q -i $(test-file) cl-hyperobject-2.12.0/README0000644000175000017500000000032010667175450014406 0ustar kevinkevinHyperobject is written by Kevin M. Rosenberg . Usage and distribution is governed by the BSD license which is in the file COPYING. The home for hyperobject is http://hyperobject.b9.com/ cl-hyperobject-2.12.0/connect.lisp0000644000175000017500000000463710667175450016067 0ustar kevinkevin;;;; -- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: connect.lisp ;;;; Purpose: Low-level SQL routines data for UMLisp ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; ;;;; $Id$ ;;;; ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* (in-package #:hyperobject) (defvar *ho-sql-db* "ho") (defun ho-sql-db () *ho-sql-db*) (defun ho-sql-db! (dbname) (sql-disconnect-pooled) (setq *ho-sql-db* dbname)) (defvar *ho-sql-user* "secret") (defun ho-sql-user () *ho-sql-user*) (defun ho-sql-user! (u) (sql-disconnect-pooled) (setq *ho-sql-user* u)) (defvar *ho-sql-passwd* "secret") (defun ho-sql-passwd () *ho-sql-passwd*) (defun ho-sql-passwd! (p) (sql-disconnect-pooled) (setq *ho-sql-passwd* p)) (defvar *ho-sql-host* "localhost") (defun ho-sql-host () *ho-sql-host*) (defun ho-sql-host! (h) (sql-disconnect-pooled) (setq *ho-sql-host* h)) (defvar *ho-sql-type* :mysql) (defun ho-sql-type () *ho-sql-type*) (defun ho-sql-type! (h) (sql-disconnect-pooled) (setq *ho-sql-type* h)) (defun sql-connect () "Connect to HO database, automatically used pooled connections" (clsql:connect `(,(ho-sql-host) ,(ho-sql-db) ,(ho-sql-user) ,(ho-sql-passwd)) :database-type *ho-sql-type* :pool t)) (defun sql-disconnect (conn) "Disconnect from HO database, but put connection back into pool" (clsql:disconnect :database conn)) (defun sql-disconnect-pooled () (clsql:disconnect-pooled)) (defmacro with-sql-connection ((conn) &body body) `(let ((,conn (sql-connect))) (unwind-protect (progn ,@body) (when ,conn (clsql:disconnect :database ,conn))))) (defun sql-query (cmd conn &key (types :auto)) (clsql:query cmd :database conn :types types)) (defun sql-execute (cmd conn) (clsql:execute-command cmd :database conn)) ;;; Pool of open connections (defmacro with-mutex-sql ((conn) &body body) `(let ((,conn (sql-connect))) (unwind-protect (progn ,@body) (when ,conn (sql-disconnect ,conn))))) (defun mutex-sql-execute (cmd) (with-mutex-sql (conn) (sql-execute cmd conn))) (defun mutex-sql-query (cmd &key (types :auto)) (with-mutex-sql (conn) (sql-query cmd conn :types types))) cl-hyperobject-2.12.0/doc/0000755000175000017500000000000011605662442014273 5ustar kevinkevincl-hyperobject-2.12.0/doc/COPYING.GFDL0000644000175000017500000004076010667175450016055 0ustar kevinkevin GNU Free Documentation License Version 1.1, March 2000 Copyright (C) 2000 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. 0. PREAMBLE The purpose of this License is to make a manual, textbook, or other written document "free" in the sense of freedom: to assure everyone the effective freedom to copy and redistribute it, with or without modifying it, either commercially or noncommercially. Secondarily, this License preserves for the author and publisher a way to get credit for their work, while not being considered responsible for modifications made by others. This License is a kind of "copyleft", which means that derivative works of the document must themselves be free in the same sense. It complements the GNU General Public License, which is a copyleft license designed for free software. We have designed this License in order to use it for manuals for free software, because free software needs free documentation: a free program should come with manuals providing the same freedoms that the software does. But this License is not limited to software manuals; it can be used for any textual work, regardless of subject matter or whether it is published as a printed book. We recommend this License principally for works whose purpose is instruction or reference. 1. APPLICABILITY AND DEFINITIONS This License applies to any manual or other work that contains a notice placed by the copyright holder saying it can be distributed under the terms of this License. The "Document", below, refers to any such manual or work. Any member of the public is a licensee, and is addressed as "you". A "Modified Version" of the Document means any work containing the Document or a portion of it, either copied verbatim, or with modifications and/or translated into another language. A "Secondary Section" is a named appendix or a front-matter section of the Document that deals exclusively with the relationship of the publishers or authors of the Document to the Document's overall subject (or to related matters) and contains nothing that could fall directly within that overall subject. (For example, if the Document is in part a textbook of mathematics, a Secondary Section may not explain any mathematics.) The relationship could be a matter of historical connection with the subject or with related matters, or of legal, commercial, philosophical, ethical or political position regarding them. The "Invariant Sections" are certain Secondary Sections whose titles are designated, as being those of Invariant Sections, in the notice that says that the Document is released under this License. The "Cover Texts" are certain short passages of text that are listed, as Front-Cover Texts or Back-Cover Texts, in the notice that says that the Document is released under this License. A "Transparent" copy of the Document means a machine-readable copy, represented in a format whose specification is available to the general public, whose contents can be viewed and edited directly and straightforwardly with generic text editors or (for images composed of pixels) generic paint programs or (for drawings) some widely available drawing editor, and that is suitable for input to text formatters or for automatic translation to a variety of formats suitable for input to text formatters. A copy made in an otherwise Transparent file format whose markup has been designed to thwart or discourage subsequent modification by readers is not Transparent. A copy that is not "Transparent" is called "Opaque". Examples of suitable formats for Transparent copies include plain ASCII without markup, Texinfo input format, LaTeX input format, SGML or XML using a publicly available DTD, and standard-conforming simple HTML designed for human modification. Opaque formats include PostScript, PDF, proprietary formats that can be read and edited only by proprietary word processors, SGML or XML for which the DTD and/or processing tools are not generally available, and the machine-generated HTML produced by some word processors for output purposes only. The "Title Page" means, for a printed book, the title page itself, plus such following pages as are needed to hold, legibly, the material this License requires to appear in the title page. For works in formats which do not have any title page as such, "Title Page" means the text near the most prominent appearance of the work's title, preceding the beginning of the body of the text. 2. VERBATIM COPYING You may copy and distribute the Document in any medium, either commercially or noncommercially, provided that this License, the copyright notices, and the license notice saying this License applies to the Document are reproduced in all copies, and that you add no other conditions whatsoever to those of this License. You may not use technical measures to obstruct or control the reading or further copying of the copies you make or distribute. However, you may accept compensation in exchange for copies. If you distribute a large enough number of copies you must also follow the conditions in section 3. You may also lend copies, under the same conditions stated above, and you may publicly display copies. 3. COPYING IN QUANTITY If you publish printed copies of the Document numbering more than 100, and the Document's license notice requires Cover Texts, you must enclose the copies in covers that carry, clearly and legibly, all these Cover Texts: Front-Cover Texts on the front cover, and Back-Cover Texts on the back cover. Both covers must also clearly and legibly identify you as the publisher of these copies. The front cover must present the full title with all words of the title equally prominent and visible. You may add other material on the covers in addition. Copying with changes limited to the covers, as long as they preserve the title of the Document and satisfy these conditions, can be treated as verbatim copying in other respects. If the required texts for either cover are too voluminous to fit legibly, you should put the first ones listed (as many as fit reasonably) on the actual cover, and continue the rest onto adjacent pages. If you publish or distribute Opaque copies of the Document numbering more than 100, you must either include a machine-readable Transparent copy along with each Opaque copy, or state in or with each Opaque copy a publicly-accessible computer-network location containing a complete Transparent copy of the Document, free of added material, which the general network-using public has access to download anonymously at no charge using public-standard network protocols. If you use the latter option, you must take reasonably prudent steps, when you begin distribution of Opaque copies in quantity, to ensure that this Transparent copy will remain thus accessible at the stated location until at least one year after the last time you distribute an Opaque copy (directly or through your agents or retailers) of that edition to the public. It is requested, but not required, that you contact the authors of the Document well before redistributing any large number of copies, to give them a chance to provide you with an updated version of the Document. 4. MODIFICATIONS You may copy and distribute a Modified Version of the Document under the conditions of sections 2 and 3 above, provided that you release the Modified Version under precisely this License, with the Modified Version filling the role of the Document, thus licensing distribution and modification of the Modified Version to whoever possesses a copy of it. In addition, you must do these things in the Modified Version: A. Use in the Title Page (and on the covers, if any) a title distinct from that of the Document, and from those of previous versions (which should, if there were any, be listed in the History section of the Document). You may use the same title as a previous version if the original publisher of that version gives permission. B. List on the Title Page, as authors, one or more persons or entities responsible for authorship of the modifications in the Modified Version, together with at least five of the principal authors of the Document (all of its principal authors, if it has less than five). C. State on the Title page the name of the publisher of the Modified Version, as the publisher. D. Preserve all the copyright notices of the Document. E. Add an appropriate copyright notice for your modifications adjacent to the other copyright notices. F. Include, immediately after the copyright notices, a license notice giving the public permission to use the Modified Version under the terms of this License, in the form shown in the Addendum below. G. Preserve in that license notice the full lists of Invariant Sections and required Cover Texts given in the Document's license notice. H. Include an unaltered copy of this License. I. Preserve the section entitled "History", and its title, and add to it an item stating at least the title, year, new authors, and publisher of the Modified Version as given on the Title Page. If there is no section entitled "History" in the Document, create one stating the title, year, authors, and publisher of the Document as given on its Title Page, then add an item describing the Modified Version as stated in the previous sentence. J. Preserve the network location, if any, given in the Document for public access to a Transparent copy of the Document, and likewise the network locations given in the Document for previous versions it was based on. These may be placed in the "History" section. You may omit a network location for a work that was published at least four years before the Document itself, or if the original publisher of the version it refers to gives permission. K. In any section entitled "Acknowledgements" or "Dedications", preserve the section's title, and preserve in the section all the substance and tone of each of the contributor acknowledgements and/or dedications given therein. L. Preserve all the Invariant Sections of the Document, unaltered in their text and in their titles. Section numbers or the equivalent are not considered part of the section titles. M. Delete any section entitled "Endorsements". Such a section may not be included in the Modified Version. N. Do not retitle any existing section as "Endorsements" or to conflict in title with any Invariant Section. If the Modified Version includes new front-matter sections or appendices that qualify as Secondary Sections and contain no material copied from the Document, you may at your option designate some or all of these sections as invariant. To do this, add their titles to the list of Invariant Sections in the Modified Version's license notice. These titles must be distinct from any other section titles. You may add a section entitled "Endorsements", provided it contains nothing but endorsements of your Modified Version by various parties--for example, statements of peer review or that the text has been approved by an organization as the authoritative definition of a standard. You may add a passage of up to five words as a Front-Cover Text, and a passage of up to 25 words as a Back-Cover Text, to the end of the list of Cover Texts in the Modified Version. Only one passage of Front-Cover Text and one of Back-Cover Text may be added by (or through arrangements made by) any one entity. If the Document already includes a cover text for the same cover, previously added by you or by arrangement made by the same entity you are acting on behalf of, you may not add another; but you may replace the old one, on explicit permission from the previous publisher that added the old one. The author(s) and publisher(s) of the Document do not by this License give permission to use their names for publicity for or to assert or imply endorsement of any Modified Version. 5. COMBINING DOCUMENTS You may combine the Document with other documents released under this License, under the terms defined in section 4 above for modified versions, provided that you include in the combination all of the Invariant Sections of all of the original documents, unmodified, and list them all as Invariant Sections of your combined work in its license notice. The combined work need only contain one copy of this License, and multiple identical Invariant Sections may be replaced with a single copy. If there are multiple Invariant Sections with the same name but different contents, make the title of each such section unique by adding at the end of it, in parentheses, the name of the original author or publisher of that section if known, or else a unique number. Make the same adjustment to the section titles in the list of Invariant Sections in the license notice of the combined work. In the combination, you must combine any sections entitled "History" in the various original documents, forming one section entitled "History"; likewise combine any sections entitled "Acknowledgements", and any sections entitled "Dedications". You must delete all sections entitled "Endorsements." 6. COLLECTIONS OF DOCUMENTS You may make a collection consisting of the Document and other documents released under this License, and replace the individual copies of this License in the various documents with a single copy that is included in the collection, provided that you follow the rules of this License for verbatim copying of each of the documents in all other respects. You may extract a single document from such a collection, and distribute it individually under this License, provided you insert a copy of this License into the extracted document, and follow this License in all other respects regarding verbatim copying of that document. 7. AGGREGATION WITH INDEPENDENT WORKS A compilation of the Document or its derivatives with other separate and independent documents or works, in or on a volume of a storage or distribution medium, does not as a whole count as a Modified Version of the Document, provided no compilation copyright is claimed for the compilation. Such a compilation is called an "aggregate", and this License does not apply to the other self-contained works thus compiled with the Document, on account of their being thus compiled, if they are not themselves derivative works of the Document. If the Cover Text requirement of section 3 is applicable to these copies of the Document, then if the Document is less than one quarter of the entire aggregate, the Document's Cover Texts may be placed on covers that surround only the Document within the aggregate. Otherwise they must appear on covers around the whole aggregate. 8. TRANSLATION Translation is considered a kind of modification, so you may distribute translations of the Document under the terms of section 4. Replacing Invariant Sections with translations requires special permission from their copyright holders, but you may include translations of some or all Invariant Sections in addition to the original versions of these Invariant Sections. You may include a translation of this License provided that you also include the original English version of this License. In case of a disagreement between the translation and the original English version of this License, the original English version will prevail. 9. TERMINATION You may not copy, modify, sublicense, or distribute the Document except as expressly provided for under this License. Any other attempt to copy, modify, sublicense or distribute the Document is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 10. FUTURE REVISIONS OF THIS LICENSE The Free Software Foundation may publish new, revised versions of the GNU Free Documentation License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. See http://www.gnu.org/copyleft/. Each version of the License is given a distinguishing version number. If the Document specifies that a particular numbered version of this License "or any later version" applies to it, you have the option of following the terms and conditions either of that specified version or of any later version that has been published (not as a draft) by the Free Software Foundation. If the Document does not specify a version number of this License, you may choose any version ever published (not as a draft) by the Free Software Foundation. cl-hyperobject-2.12.0/doc/Makefile0000644000175000017500000000670111605662000015725 0ustar kevinkevin#!/usr/bin/make ############################################################################### # FILE IDENTIFICATION # # Name: Makefile # Purpose: Makefile for the hyperobject documentation # Programer: Kevin M. Rosenberg # Date Started: Mar 2002 # # This file, part of HYPEROBJECT, is Copyright (c) 2002-2011 by Kevin M. Rosenberg # # HYPEROBJECT users are granted the rights to distribute and use this software # as governed by the terms of the Lisp Lesser GNU Public License # (http://opensource.franz.com/preamble.html), also known as the LLGPL. ############################################################################### DOCFILE_BASE_DEFAULT:=hyperobject DOCFILE_EXT_DEFAULT:=xml # Standard docfile processing DEBIAN=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Debian.*') SUSE=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*SuSE.*') SUSE91=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*SuSE Linux 9.1.*') REDHAT=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Red Hat.*') MANDRAKE=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Mandrake.*') DARWIN=$(shell expr "`uname -a`" : '.*Darwin.*') UBUNTU=$(shell expr "`cat /etc/issue 2> /dev/null`" : '.*Ubuntu.*') ifneq (${DEBIAN},0) OS:=debian else ifneq (${SUSE91},0) OS=suse91 else ifneq (${SUSE},0) OS=suse else ifneq (${REDHAT},0) OS=redhat else ifneq (${MANDRAKE},0) OS=mandrake else ifneq (${DARWIN},0) OS=darwin else ifneq (${UBUNTU},0) OS:=debian endif endif endif endif endif endif endif ifndef DOCFILE_BASE DOCFILE_BASE=${DOCFILE_BASE_DEFAULT} endif ifndef DOCFILE_EXT DOCFILE_EXT=${DOCFILE_EXT_DEFAULT} endif DOCFILE:=${DOCFILE_BASE}.${DOCFILE_EXT} FOFILE:=${DOCFILE_BASE}.fo PDFFILE:=${DOCFILE_BASE}.pdf PSFILE:=${DOCFILE_BASE}.ps DVIFILE:=${DOCFILE_BASE}.dvi TXTFILE:=${DOCFILE_BASE}.txt HTMLFILE:=${DOCFILE_BASE}.html TMPFILES:=${DOCFILE_BASE}.aux ${DOCFILE_BASE}.out ${DOCFILE_BASE}.log DOCFILES:=$(shell echo *.xml *.xsl) ifeq ($(XSLTPROC),) XSLTPROC:=xsltproc endif CATALOG:=`pwd`/catalog-${OS}.xml CHECK:=XML_CATALOG_FILES="$(CATALOG)" xmllint --noout --xinclude --postvalid $(DOCFILE) || exit 1 .PHONY: all all: html pdf .PHONY: dist dist: html pdf .PHONY: doc doc: html pdf .PHONY: check check: @echo "Operating system detected: ${OS}" @$(CHECK) .PHONY: html html: html.tar.gz html.tar.gz: $(DOCFILES) Makefile @rm -rf html @mkdir html @XML_CATALOG_FILES="$(CATALOG)" $(XSLTPROC) --stringparam chunker.output.encoding UTF-8 \ --xinclude --output html/ html_chunk.xsl $(DOCFILE) @GZIP='-9' tar czf html.tar.gz html .PHONY: fo fo: ${FOFILE} ${FOFILE}: $(DOCFILES) Makefile @XML_CATALOG_FILES="$(CATALOG)" xsltproc --xinclude --stringparam fop1.extensions 1 --output $(FOFILE) fo.xsl $(DOCFILE) .PHONY: pdf pdf: ${PDFFILE} ${PDFFILE}: ${DOCFILES} Makefile @$(MAKE) fo @fop $(FOFILE) -pdf $(PDFFILE) > /dev/null .PHONY: dvi dvi: ${DVIFILE} .PHONY: ps ps: ${PSFILE} ${PSFILE}: ${DOCFILES} Makefile @$(MAKE) fo @fop $(FOFILE) -ps $(PSFILE) > /dev/null .PHONY: txt txt: ${TXTFILE} ${TXTFILE}: ${FOFILE} @XML_CATALOG_FILES="$(CATALOG)" xsltproc --xinclude --output ${HTMLFILE} html.xsl $(DOCFILE) lynx -dump ${HTMLFILE} > ${TXTFILE} .PHONY: clean clean: @rm -f *~ *.bak *.orig \#*\# .\#* texput.log @rm -rf html ${PSFILE} ${HTMLFILE} @rm -f ${TMPFILES} ${FOFILE} @rm -f ${DVIFILE} ${TXTFILE} .PHONY: distclean distclean: clean cl-hyperobject-2.12.0/doc/bookinfo.xml0000644000175000017500000000407110667175450016632 0ustar kevinkevin %myents; ]> &hyperobject; Reference Guide Kevin M. Rosenberg Heart Hospital of New Mexico
kevin@rosenberg.net 504 Elm Street N.E. Albuquerque New Mexico 87102
$Id$ File $Date$ 2002-2003 Kevin M. Rosenberg The &hyperobject; package was designed and written by Kevin M. Rosenberg. Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.1 or any later version published by the Free Software Foundation; with no Invariant Sections, with the no Front-Cover Texts, and with no Back-Cover Texts. A copy of the license is included in the &hyperobject; distribution. Allegro CL® is a registered trademark of Franz Inc. Lispworks® is a registered trademark of Xanalys Inc. Microsoft Windows® is a registered trademark of Microsoft Inc. Other brand or product names are the registered trademarks or trademarks of their respective holders. cl-hyperobject-2.12.0/doc/catalog-debian.xml0000644000175000017500000000266010667175450017660 0ustar kevinkevin cl-hyperobject-2.12.0/doc/catalog-suse.xml0000644000175000017500000000262010667175450017411 0ustar kevinkevin cl-hyperobject-2.12.0/doc/dsssl/0000755000175000017500000000000010667175450015430 5ustar kevinkevincl-hyperobject-2.12.0/doc/dsssl/COPYRIGHT0000644000175000017500000000022610667175450016723 0ustar kevinkevinThese stylesheets are written and Copyright (c) 1999-2002 by Pierre R. Mai. He has graciously placed them in the public domain without restrictions. cl-hyperobject-2.12.0/doc/dsssl/html/0000755000175000017500000000000010667175450016374 5ustar kevinkevincl-hyperobject-2.12.0/doc/dsssl/html/docbook.dsl0000644000175000017500000000172210667175450020522 0ustar kevinkevin ]> (element envar ($mono-seq$)) (element symbol ($mono-seq$)) (element type ($mono-seq$)) (element errortype ($mono-seq$)) (element returnvalue ($italic-mono-seq$)) (define (book-titlepage-recto-elements) (list (normalize "title") (normalize "subtitle") (normalize "graphic") (normalize "corpauthor") (normalize "authorgroup") (normalize "author") (normalize "editor") (normalize "printhistory") (normalize "copyright") (normalize "abstract") (normalize "legalnotice"))) (define %use-id-as-filename% #t) (define use-output-dir #t) cl-hyperobject-2.12.0/doc/dsssl/print/0000755000175000017500000000000010667175450016564 5ustar kevinkevincl-hyperobject-2.12.0/doc/dsssl/print/docbook.dsl0000644000175000017500000000172310667175450020713 0ustar kevinkevin ]> (element envar ($mono-seq$)) (element symbol ($mono-seq$)) (element type ($mono-seq$)) (element errortype ($mono-seq$)) (element returnvalue ($italic-mono-seq$)) (define (book-titlepage-verso-elements) (list (normalize "title") (normalize "subtitle") (normalize "corpauthor") (normalize "authorgroup") (normalize "author") (normalize "editor") (normalize "edition") (normalize "pubdate") (normalize "printhistory") (normalize "copyright") (normalize "abstract") (normalize "legalnotice") (normalize "revhistory"))) cl-hyperobject-2.12.0/doc/entities.inc0000644000175000017500000000163710667175450016626 0ustar kevinkevinHyperobject"> UFFI"> FFI"> CMUCL"> SCL"> Lispworks"> SBCL"> OpenMCL"> MCL"> AllegroCL"> ANSI Common Lisp"> T"> NIL"> NULL"> C"> ASDF"> KMRCL"> CLSQL"> cl-hyperobject-2.12.0/doc/fo.xsl0000644000175000017500000000033311605662164015427 0ustar kevinkevin cl-hyperobject-2.12.0/doc/html.tar.gz0000644000175000017500000000524511605662174016376 0ustar kevinkevin|dNRH]JȖ%k2L&Hfi-^$ݲ^e?/sZ-[PqSKj{>aPXkתcqv݆ܨ;N 'TqɆ&P*h )J1֌awPDI ,ۙBUhftه(=UF ٦ m*gܽ%G U.<2Nb0"Ih794_|ا#,@*$0ڵ$'X7!yWhVI0c| -8Oĉ7m|L^{l INpnzk_⑐ji)o>[!7SLu{nW)~VW"gNsWv}!3>fI>y쎛z&p?S:҇{[@ٕqNr9OE1] əsv̈0x͍x_ɴWW{{Lj5fȷͩ,?mFLiӵ{%`3#\N'X36&ȝ2S;&x(P3?|oЂ Y*R pCR? ?jM}AOAڽڮk 5*?Ls.L* k_5 n\l6%H/O77_R}8e.)$O iypvd,NsSa|'@}~OuJB <[+)F#[D/u;bK+]\x1ZN('J<|a |?camtV*oP Q c[r[oxTr6prXCL ֒=[IUs;~[Njy݇(`l*<=r)S" #1l%&QƉs6_x]s9{ t){"9-nlq9A1#!S?6Im\0cf|H̱H6_h1xb$K9S 3XL$Zݿ`L-brP1q u˅AŷiWP|{ڂP“ZN}gl5[ʻC1@ʭ{)vr-՛껕̬{nwm\*Q޹Tː Z{M'{QuJ"Ocd-^Ɖߧ_RYf1 \Td#ah7 [,"/ Ein *+!NI5晼ϛ|ϵ%щ ,:mB.|wΗxLڬ.<< ?$b$N$$]CexOq1i;P;̞I5E_+ WF,Hȴ#MΙV !DIU6#/`Pi34_|jz母dr Wǜ7%4|IW%iccZB%2|'}JY4X=)w7 dh&o/KHzn'ѪDqdΏ[Sb(^`6Ǔh*F2*Qs4Gsn=ޥݼ]QܵMʥ;TLugQ7.W岌;U'YUuEp=c=c=c=c=c=YfKPcl-hyperobject-2.12.0/doc/html.xsl0000644000175000017500000000042610667175450015776 0ustar kevinkevin cl-hyperobject-2.12.0/doc/html_chunk.xsl0000644000175000017500000000034410667175450017165 0ustar kevinkevin cl-hyperobject-2.12.0/doc/hyperobject.xml0000644000175000017500000000071610667175450017344 0ustar kevinkevin %myents; %xinclude; ]> cl-hyperobject-2.12.0/doc/intro.xml0000644000175000017500000000510110667175450016152 0ustar kevinkevin %myents; ]> Introduction Purpose This reference guide describes &hyperobject;, which provides an object representation library for Common Lisp programs. Supported Implementations The primary tested and supported platforms for &hyperobject; are: &acl; v6.2 &lw; v4.3 &cmucl; 18e &sbcl; 0.8.5 &scl; 1.1.1 &openmcl; 0.14 Installation Download You need to download the &hyperobject; package from its web home. Other required packages are: &kmrcl; &uffi; &clsql; &asdf; from it's home CCLAN package. You can download the file asdf.lisp from the CVS tree. Loading After downloading and installing &asdf;, simply push the directories containing &hyperobject;, &kmrcl;, &uffi;, and &clsql; onto asdf:*central-registry* variable. Whenever you want to load the &hyperobject; package, use the function (asdf:operate 'asdf:load-op :hyperobject). cl-hyperobject-2.12.0/doc/xinclude.mod0000644000175000017500000000160110667175450016612 0ustar kevinkevin cl-hyperobject-2.12.0/doc/hyperobject.pdf0000644000175000017500000005105311605662200017300 0ustar kevinkevin%PDF-1.4 % 4 0 obj << /Title (Hyperobject Reference Guide) /Author (Kevin M. Rosenberg) /Creator (DocBook XSL Stylesheets with Apache FOP) /Producer (Apache FOP Version 0.95) /CreationDate (D:20110708201143Z) >> endobj 5 0 obj << /N 3 /Length 11 0 R /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 6 0 obj [/ICCBased 5 0 R] endobj 7 0 obj << /Type /Metadata /Subtype /XML /Length 12 0 R >> stream Hyperobject Reference Guide Kevin M. Rosenberg 2011-07-08T20:11:43Z 1.4 Apache FOP Version 0.95 2011-07-08T20:11:43Z DocBook XSL Stylesheets with Apache FOP 2011-07-08T20:11:43Z endstream endobj 10 0 obj << /Length 13 0 R /Filter /FlateDecode >> stream xuM 0 9nk ~xPz/L{;ʛINOB^EH=BH-Z~BBpXja-:ݣ08Ad@KR*!s~I`~ T* +.:zr-Tas+-oNep`_9ʺs-DV37N<'QG endstream endobj 8 0 obj << /Resources 3 0 R /Type /Page /MediaBox [0 0 612 792] /BleedBox [0 0 612 792] /TrimBox [0 0 612 792] /Parent 1 0 R /Contents 10 0 R >> endobj 11 0 obj 2596 endobj 12 0 obj 885 endobj 13 0 obj 192 endobj 15 0 obj << /Length 16 0 R /Filter /FlateDecode >> stream xVK'Wp,r7:m%NhIdGf݃.Ut3 `Wԛ?#|aP䎕d`J )tBX#>Bf9l2 ͝? $|*Qm SeӰ:Kuyskg#;tzΊ=vmMzX߯磫Yj+ҝ: 7J ?\i@IY2xJkjhٱ2Qd0!wo# Eʕ34PO@Zlֺ $iE2 gy,h%ܳЧQY4H#5t5#{4=!j=TIa9McMŶ歹/Rjb+NiM}6gWH`&eY>H7*7L)&IVئ3WcL-}mː0%[4 &+!CF4ly\c$wuX5M1|BCLH{gYe5F9cxLS;1-VO tx|XvhZ5}v7n?>T2&駠pL[.7|_IV;6MfLm3)\}}= iy!J ;(?0{3ߞj;݇1nkv]C SMGk| #:ih55z```bUc3'zնt%]׷%dTnte ѧE˪J!#ej{N}VjqifIU(H-PE폌7`/Yux$۾In56Ac]JņO}doPm{kњF07ߍg endstream endobj 14 0 obj << /Resources 3 0 R /Type /Page /MediaBox [0 0 612 792] /BleedBox [0 0 612 792] /TrimBox [0 0 612 792] /Parent 1 0 R /Contents 15 0 R >> endobj 16 0 obj 911 endobj 17 0 obj << /Type /Metadata /Subtype /XML /Length 36 0 R >> stream en Hyperobject Reference Guide Kevin M. Rosenberg 2011-07-08T20:11:43Z 2011-07-08T20:11:43Z 2011-07-08T20:11:43Z 1.4 Apache FOP Version 0.95 2011-07-08T20:11:43Z DocBook XSL Stylesheets with Apache FOP 2011-07-08T20:11:44Z endstream endobj 19 0 obj << /Type /Metadata /Subtype /XML /Length 37 0 R >> stream en Hyperobject Reference Guide Kevin M. Rosenberg 2011-07-08T20:11:43Z 2011-07-08T20:11:43Z 2011-07-08T20:11:43Z 1.4 Apache FOP Version 0.95 2011-07-08T20:11:43Z DocBook XSL Stylesheets with Apache FOP 2011-07-08T20:11:44Z endstream endobj 21 0 obj << /Type /Annot /Subtype /Link /Rect [ 374.13 346.256 395.79 355.256 ] /C [ 0 0 0 ] /Border [ 0 0 0 ] /A << /URI (http://hyperobject.b9.com/) /S /URI >> /H /I >> endobj 23 0 obj << /Type /Annot /Subtype /Link /Rect [ 402.205 346.256 508.315 355.256 ] /C [ 0 0 0 ] /Border [ 0 0 0 ] /A << /URI (http://hyperobject.b9.com/) /S /URI >> /H /I >> endobj 24 0 obj << /Type /Annot /Subtype /Link /Rect [ 130.0 312.256 163.34 321.256 ] /C [ 0 0 0 ] /Border [ 0 0 0 ] /A << /URI (http://files.b9.com/kmrcl/) /S /URI >> /H /I >> endobj 25 0 obj << /Type /Annot /Subtype /Link /Rect [ 169.17 312.256 271.4 321.256 ] /C [ 0 0 0 ] /Border [ 0 0 0 ] /A << /URI (http://files.b9.com/kmrcl/) /S /URI >> /H /I >> endobj 26 0 obj << /Type /Annot /Subtype /Link /Rect [ 130.0 290.256 152.77 299.256 ] /C [ 0 0 0 ] /Border [ 0 0 0 ] /A << /URI (http://files.b9.com/uffi/) /S /URI >> /H /I >> endobj 27 0 obj << /Type /Annot /Subtype /Link /Rect [ 158.6 290.256 251.94 299.256 ] /C [ 0 0 0 ] /Border [ 0 0 0 ] /A << /URI (http://files.b9.com/uffi/) /S /URI >> /H /I >> endobj 28 0 obj << /Type /Annot /Subtype /Link /Rect [ 130.0 268.256 160.01 277.256 ] /C [ 0 0 0 ] /Border [ 0 0 0 ] /A << /URI (http://files.b9.com/clsql/) /S /URI >> /H /I >> endobj 29 0 obj << /Type /Annot /Subtype /Link /Rect [ 165.84 268.256 263.63 277.256 ] /C [ 0 0 0 ] /Border [ 0 0 0 ] /A << /URI (http://files.b9.com/clsql/) /S /URI >> /H /I >> endobj 30 0 obj << /Type /Annot /Subtype /Link /Rect [ 216.955 246.25601 248.63501 255.25601 ] /C [ 0 0 0 ] /Border [ 0 0 0 ] /A << /URI (http://www.sourceforge.net/projects/cclan) /S /URI >> /H /I >> endobj 31 0 obj << /Type /Annot /Subtype /Link /Rect [ 254.087 246.25601 422.38702 255.25601 ] /C [ 0 0 0 ] /Border [ 0 0 0 ] /A << /URI (http://www.sourceforge.net/projects/cclan) /S /URI >> /H /I >> endobj 32 0 obj << /Type /Annot /Subtype /Link /Rect [ 287.513 234.25601 303.063 243.25601 ] /C [ 0 0 0 ] /Border [ 0 0 0 ] /A << /URI (http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/asdf.lisp) /S /URI >> /H /I >> endobj 33 0 obj << /Type /Annot /Subtype /Link /Rect [ 310.86798 234.25601 539.998 243.25601 ] /C [ 0 0 0 ] /Border [ 0 0 0 ] /A << /URI (http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/asdf.lisp) /S /URI >> /H /I >> endobj 34 0 obj << /Type /Annot /Subtype /Link /Rect [ 130.0 222.25601 163.61 231.25601 ] /C [ 0 0 0 ] /Border [ 0 0 0 ] /A << /URI (http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/asdf.lisp) /S /URI >> /H /I >> endobj 35 0 obj << /Length 38 0 R /Filter /FlateDecode >> stream x[F=7ǝ̅a`4v[ZkwG}`$@p0_l>ffGPy {qi(,킶WS#8Kgu <\9N3lf5 u QT #6ء>椞%ߚߚm}YkWjJaG?W;;F HY!9;ӜCXJ3ErZ*8Y8\e.H!^+YDy uFg$L ٿ=e=+r\e .c@&s]6:`gGкg\wd}. a$~Q\]f]-i}&̠&w^ ";Y^U/}"wd pp1m@vĻy)0m C> KĮ+c@Y0* ³+Msy="X3D6ڋ$<[6=DC/nT8ewGKh˷:/P\@{񅾌,Sq_Ls6 # 1E w{մ&JbiQI-|N.<pUvJ,\M&NɅqCOv5fgʶ@nW~KsUYj\V؇6UYg]a5leѻ?ɇK `"°j*v3QD$c v\e%,׋6(-fDSe2bsA&D<(5S!ύMۋFyV16: F@n*(m9Mq"_wyXA.&; A|hF"a :``9^Ƕ;A<w X޽GhP'>() eA^:L&0odh/^4w? O X7>pn;M-{\c[}u@"6EDt:";䑄%q#Q*A(JBk{f#C90ơxZ!ݴ`Q{b`(hKSa؃4q>HO3yj1D*"aQ뺜o]}7ò ौ ΝRJ4|{*yIXXm⫇8]cyRιrT0>x}fyM+Ik~[*9u^ -dan&wJ^ Qwuy' ޝހM4֞ E G4qCHB@'Y-kCaۉ,%G0lt*Ӕ|ўB P-&}ߋբ||z`zfau=*N | h&e=X ejbUA]?dZarM\㳉JR#⥩v 8|H߂?ne*ܯ´C C 8 e7QN!ίFC?Qo%s  ˖ wX1ӉQ>"m}+nYp endstream endobj 22 0 obj [ 21 0 R 23 0 R 24 0 R 25 0 R 26 0 R 27 0 R 28 0 R 29 0 R 30 0 R 31 0 R 32 0 R 33 0 R 34 0 R ] endobj 20 0 obj << /Resources 3 0 R /Type /Page /MediaBox [0 0 612 792] /BleedBox [0 0 612 792] /TrimBox [0 0 612 792] /Parent 1 0 R /Annots 22 0 R /Contents 35 0 R >> endobj 36 0 obj 1031 endobj 37 0 obj 1031 endobj 38 0 obj 1625 endobj 40 0 obj << /Type /Annot /Subtype /Link /Rect [ 120.0 680.124 180.461 689.124 ] /C [ 0 0 0 ] /Border [ 0 0 0 ] /A 39 0 R /H /I >> endobj 42 0 obj << /Type /Annot /Subtype /Link /Rect [ 534.926 680.124 539.926 689.124 ] /C [ 0 0 0 ] /Border [ 0 0 0 ] /A 39 0 R /H /I >> endobj 44 0 obj << /Type /Annot /Subtype /Link /Rect [ 144.0 668.124 176.22 677.124 ] /C [ 0 0 0 ] /Border [ 0 0 0 ] /A 43 0 R /H /I >> endobj 45 0 obj << /Type /Annot /Subtype /Link /Rect [ 534.996 668.124 539.996 677.124 ] /C [ 0 0 0 ] /Border [ 0 0 0 ] /A 43 0 R /H /I >> endobj 47 0 obj << /Type /Annot /Subtype /Link /Rect [ 144.0 656.124 255.659 665.124 ] /C [ 0 0 0 ] /Border [ 0 0 0 ] /A 46 0 R /H /I >> endobj 48 0 obj << /Type /Annot /Subtype /Link /Rect [ 534.921 656.124 539.921 665.124 ] /C [ 0 0 0 ] /Border [ 0 0 0 ] /A 46 0 R /H /I >> endobj 50 0 obj << /Type /Annot /Subtype /Link /Rect [ 144.0 644.124 189.0 653.124 ] /C [ 0 0 0 ] /Border [ 0 0 0 ] /A 49 0 R /H /I >> endobj 51 0 obj << /Type /Annot /Subtype /Link /Rect [ 534.996 644.124 539.996 653.124 ] /C [ 0 0 0 ] /Border [ 0 0 0 ] /A 49 0 R /H /I >> endobj 53 0 obj << /Type /Annot /Subtype /Link /Rect [ 168.0 632.124 209.66 641.124 ] /C [ 0 0 0 ] /Border [ 0 0 0 ] /A 52 0 R /H /I >> endobj 54 0 obj << /Type /Annot /Subtype /Link /Rect [ 534.995 632.124 539.995 641.124 ] /C [ 0 0 0 ] /Border [ 0 0 0 ] /A 52 0 R /H /I >> endobj 56 0 obj << /Type /Annot /Subtype /Link /Rect [ 168.0 620.124 201.33 629.124 ] /C [ 0 0 0 ] /Border [ 0 0 0 ] /A 55 0 R /H /I >> endobj 57 0 obj << /Type /Annot /Subtype /Link /Rect [ 534.996 620.124 539.996 629.124 ] /C [ 0 0 0 ] /Border [ 0 0 0 ] /A 55 0 R /H /I >> endobj 58 0 obj << /Length 59 0 R /Filter /FlateDecode >> stream xOo#;?3U]U8A1, ْ_?C)4eV&yѢRƿSv,ڟnj}<,Om5Bc_?w]Yf)c=:ݷ/)__@_fkol"otty{~:i4ߜUߤgeǫҖZ1^RckzXwwwrݟ,sv8{}0acc/~4W?~[种o㧧yGQ{4Zryxǻ([K쭗y&_e_Z-E١kQ> endobj 59 0 obj 2283 endobj 62 0 obj << /Title (Hyperobject Reference Guide) /Parent 61 0 R /Next 64 0 R /A 60 0 R >> endobj 64 0 obj << /Title (Table of Contents) /Parent 61 0 R /Prev 62 0 R /Next 65 0 R /A 63 0 R >> endobj 65 0 obj << /Title /Parent 61 0 R /Prev 64 0 R /First 66 0 R /Last 68 0 R /Count -5 /A 39 0 R >> endobj 66 0 obj << /Title (Purpose) /Parent 65 0 R /Next 67 0 R /A 43 0 R >> endobj 67 0 obj << /Title (Supported Implementations) /Parent 65 0 R /Prev 66 0 R /Next 68 0 R /A 46 0 R >> endobj 68 0 obj << /Title (Installation) /Parent 65 0 R /Prev 67 0 R /First 69 0 R /Last 70 0 R /Count -2 /A 49 0 R >> endobj 69 0 obj << /Title (Download) /Parent 68 0 R /Next 70 0 R /A 52 0 R >> endobj 70 0 obj << /Title (Loading) /Parent 68 0 R /Prev 69 0 R /A 55 0 R >> endobj 71 0 obj << /Type /Font /Subtype /Type1 /BaseFont /Times-Roman /Encoding /WinAnsiEncoding >> endobj 72 0 obj << /Type /Font /Subtype /Type1 /BaseFont /Helvetica-BoldOblique /Encoding /WinAnsiEncoding >> endobj 73 0 obj << /Type /Font /Subtype /Type1 /BaseFont /Helvetica-Bold /Encoding /WinAnsiEncoding >> endobj 74 0 obj << /Type /Font /Subtype /Type1 /BaseFont /Courier /Encoding /WinAnsiEncoding >> endobj 75 0 obj << /Type /Font /Subtype /Type1 /BaseFont /Times-Italic /Encoding /WinAnsiEncoding >> endobj 1 0 obj << /Type /Pages /Count 4 /Kids [8 0 R 14 0 R 18 0 R 20 0 R ] >> endobj 2 0 obj << /Type /Catalog /Pages 1 0 R /Metadata 19 0 R /Lang (en) /PageLabels 9 0 R /Outlines 61 0 R /PageMode /UseOutlines >> endobj 3 0 obj << /Font << /F5 71 0 R /F4 72 0 R /F3 73 0 R /F9 74 0 R /F6 75 0 R >> /ProcSet [ /PDF /ImageB /ImageC /Text ] /ColorSpace << /DefaultRGB 6 0 R >> >> endobj 9 0 obj << /Nums [0 << /P (1) >> 1 << /P (2) >> 2 << /P (iii) >> 3 << /P (1) >> ] >> endobj 39 0 obj << /Type /Action /S /GoTo /D [20 0 R /XYZ 72.0 720.0 null] >> endobj 43 0 obj << /Type /Action /S /GoTo /D [20 0 R /XYZ 72.0 690.141 null] >> endobj 46 0 obj << /Type /Action /S /GoTo /D [20 0 R /XYZ 72.0 621.258 null] >> endobj 49 0 obj << /Type /Action /S /GoTo /D [20 0 R /XYZ 72.0 432.375 null] >> endobj 52 0 obj << /Type /Action /S /GoTo /D [20 0 R /XYZ 72.0 397.492 null] >> endobj 55 0 obj << /Type /Action /S /GoTo /D [20 0 R /XYZ 72.0 220.75601 null] >> endobj 60 0 obj << /Type /Action /S /GoTo /D [8 0 R /XYZ 72.0 720.0 null] >> endobj 61 0 obj << /First 62 0 R /Last 65 0 R >> endobj 63 0 obj << /Type /Action /S /GoTo /D [18 0 R /XYZ 72.0 720.0 null] >> endobj xref 0 76 0000000000 65535 f 0000018174 00000 n 0000018253 00000 n 0000018403 00000 n 0000000015 00000 n 0000000223 00000 n 0000002905 00000 n 0000002938 00000 n 0000004181 00000 n 0000018579 00000 n 0000003913 00000 n 0000004348 00000 n 0000004369 00000 n 0000004389 00000 n 0000005396 00000 n 0000004409 00000 n 0000005564 00000 n 0000005584 00000 n 0000016522 00000 n 0000006706 00000 n 0000012148 00000 n 0000007828 00000 n 0000012037 00000 n 0000008007 00000 n 0000008188 00000 n 0000008366 00000 n 0000008544 00000 n 0000008721 00000 n 0000008898 00000 n 0000009076 00000 n 0000009255 00000 n 0000009457 00000 n 0000009659 00000 n 0000009885 00000 n 0000010113 00000 n 0000010336 00000 n 0000012333 00000 n 0000012354 00000 n 0000012375 00000 n 0000018675 00000 n 0000012396 00000 n 0000016418 00000 n 0000012534 00000 n 0000018753 00000 n 0000012674 00000 n 0000012811 00000 n 0000018833 00000 n 0000012951 00000 n 0000013089 00000 n 0000018913 00000 n 0000013229 00000 n 0000013365 00000 n 0000018993 00000 n 0000013505 00000 n 0000013642 00000 n 0000019073 00000 n 0000013782 00000 n 0000013919 00000 n 0000014059 00000 n 0000016707 00000 n 0000019155 00000 n 0000019232 00000 n 0000016728 00000 n 0000019282 00000 n 0000016828 00000 n 0000016932 00000 n 0000017141 00000 n 0000017221 00000 n 0000017333 00000 n 0000017458 00000 n 0000017539 00000 n 0000017619 00000 n 0000017728 00000 n 0000017847 00000 n 0000017959 00000 n 0000018064 00000 n trailer << /Size 76 /Root 2 0 R /Info 4 0 R /ID [<22A200E836F1F0220FED88880305D466> <22A200E836F1F0220FED88880305D466>] >> startxref 19360 %%EOF cl-hyperobject-2.12.0/docs/0000755000175000017500000000000010667175450014463 5ustar kevinkevincl-hyperobject-2.12.0/docs/Makefile0000644000175000017500000000016110667175450016121 0ustar kevinkevin.PHONY: site all clean all: site site: openmcl --load `pwd`/make.lisp clean: @rm -f *~ \#*\# .\#* memdump cl-hyperobject-2.12.0/docs/hyperobject.doc0000644000175000017500000006000010667175450017464 0ustar kevinkevinࡱ> +-*@  jbjb "hh l00000 <40 ||||||||h j j j j j j ,  ||||| ||||||h 00|h p ~004 yyHyperobject User Guide Kevin Rosenberg Last Revision: December 2002 Overview Hyperobject is a Common Lisp object representation library based on the Metaobject Protocol. Reference Class options sql-nameOverrides default name of SQL table.versionSets the version number of the class. Can be used to convert previous version of the class.instantiableThe class can be instantiated by the user (default: T)descriptionThe class description.storedStore objects in SQL database (default: T) default-print-slotsList of slots to print in automatic (category-based) viewsdirect-rulesList of rules to fire when a slot value changes.Slot options sql-nameOverride name of the SQL columnuniqueThe values in the slot must be uniquestoredThe values in the slot are stored in the database.indexedThe values of the slot are indexed in the database.nil-textThe text to print if the slot is NILvalue-typeSets the data type for the field. See the next section for complete detailsinverseSets the name of an automatically generated lookup function based on a key value for this slot.print-formatterFunction used to convert slot value to a printed representationhyperlinkName of a function used to pass as a hyperlink based on this slot as a key valuehyperlink-paramsAdditional parameters to add to hyperlink URL.subobjectIndicates this slot contains a list of hyperobjects. If value for this slot option is a list, then the first element of the list is the name of the lookup function if the slot is unbound and additional list items indicate the keys from the object to pass to the lookup function.value-constraintPredicate to check if a value is allowed for the slot. Predicate takes 3 parameters (value slot-name object).null-allowedBoolean flag if null (nil) values are allowed for this slotType field Valid types for a hyperobject slot along with their corresponding SQL types are listed in the below table. stringTEXT(string n) (varchar n)VARCHAR(n)(char n)CHAR(n)characterCHAR(1)float single-floatfloatdouble-floatdoubleblobBLOBSubobject field This field sets up the storage of a slot of hold a cached object or list of objects. A lookup function and the keys to the function are also specified. The format for the subobject field is: ( keys*) 'CENZWdDQ# * ` h P `  > H ` q * + 3  5OJQJOJQJ 6OJQJ 5OJQJOJQJCJ(9'DENVWdH$$If0qk!634a$If'ENVWdCDQ" # + _ ` i O P `  = > H _ ` 8  '(-23C  ]CDQ@$IfH$$If0qk!634a " # + _ ` i O P ` `D$IfH$$If0"!y634a`  = > H _ ` q ) * + , - p( H$$If0"!y634a$If- 8 HLhTH$$If0l 634a$If '(-23C  ,H$$If0l 634a$If / =!"#$% i4@4NormalCJOJPJQJmH D`D Heading 1$@@&CJ0KH OJQJB`"B Heading 2 <@&CJ$OJQJnH B`2B Heading 3 @&CJ OJQJnH 8@8 Heading 4$@& CJOJQJ<A@<Default Paragraph Font8O8sectiondd[$\$CJnH :>`":Title @&CJ8KHOJQJ "  ` -     NYWcy >Go{JU3< WcDJQ#*`cPU>G`e  &(,   :::::::::::::::::::::::::::::::::::Kevin Rosenberg>System:Users:kevin:debian:src:hyperobject:docs:hyperobject.docKevin RosenbergPSystem:Users:kevin:Documents:Microsoft User Data:AutoRecovery save of hyperobjecKevin RosenbergCSystem:Users:kevin:Documents:Microsoft User Data:Word Work File A_4Kevin RosenbergCSystem:Users:kevin:Documents:Microsoft User Data:Word Work File A_4VWdCDQ"#+_`iOP`=>H_`q)*+,-  '(-23 @d@{# 0 @GTimes New Roman5Symbol3 ArialaITC Garamond Std Book NarrowaITC Garamond Std Bold Narrow3Timesg ITC Garamond Std Bold Narrow It 1hjl%klENu$0d( kHyperobject DocumentationKevin RosenbergKevin Rosenberg Oh+'0x  4 @ LX`hp'Hyperobject Documentation.ypeKevin RosenbergeviNormaloKevin Rosenberg4viMicrosoft Word 10.1@ޡ @΢@ߢNu ՜.+,0 `hpx  '( r Hyperobject Documentation Title  !#$%&'(),Root Entry Fi.1TableWordDocument"SummaryInformation(DocumentSummaryInformation8"CompObjX FMicrosoft Word DocumentNB6WWord.Document.8cl-hyperobject-2.12.0/docs/hyperobject.html0000644000175000017500000000515010667175450017670 0ustar kevinkevin Hyperobject Documentation

Hyperobject Documentation

Overview

Hyperobject is an Common Lisp object representation library based on the Metaobject Protocol.

Reference

Class options

sql-nameOverrides default name of SQL table.
versionSets the version number of the class. Can be used to convert previous version of the class.
instanciableIf NIL, the class can not be instanciated by the user.
descriptionThe class description.

Slot options

sql-nameOverride name of the SQL column
uniqueThe values in the slot must be unique
storedThe values in the slot are stored in the database.
indexedThe values of the slot are indexed in the database.
nil-textThe text to print if the slot is NIL
value-typeSets the data type for the field. See the next section for complete details
inverseSets the name of an automatically generated lookup function based on a key value for this slot

Type field

Valid types for a hyperobjectslot along with their coresponding SQL types are listed in the below table.

stringTEXT
(string n)
(varchar n)
VARCHAR(n)
(char n)CHAR(n)
characterCHAR(1)
float
single-float
float
double-floatdouble
blobBLOB

Subobject field

This field sets up the storage of a slot of hold a cached object or list of objects. A lookup function and the keys to the function are also specified.

The format for the subobject field is:

( keys*)

cl-hyperobject-2.12.0/docs/hyperobject.lml0000644000175000017500000000505410667175450017513 0ustar kevinkevin;; -*- Mode: Lisp -*- (page hyperobject (head (title "Hyperobject Documentation" ) (meta "Copyright" "Kevin M. Rosenberg (C) 2002") (meta "Author" "Kevin M. Rosenberg") (with link :rel "stylesheet" :href "http://b9.com/main.css" :type "text/css")) (body (h1 "Hyperobject Documentation") (h2 "Overview") (p (span-c pkgbody "Hyperobject") " is an Common Lisp object representation library based on the Metaobject Protocol.") (h2 "Reference") (h3 "Class options") (table (tbody (tr (td (b "sql-name")) (td "Overrides default name of SQL table.")) (tr (td (b "version")) (td "Sets the version number of the class. Can be used to convert previous version of the class.")) (tr (td (b "instanciable")) (td "If NIL, the class can not be instanciated by the user.")) (tr (td (b "description")) (td "The class description.")) )) (h3 "Slot options") (table (tbody (tr (td (b "sql-name")) (td "Override name of the SQL column")) (tr (td (b "unique")) (td "The values in the slot must be unique")) (tr (td (b "stored")) (td "The values in the slot are stored in the database.")) (tr (td (b "indexed")) (td "The values of the slot are indexed in the database.")) (tr (td (b "nil-text")) (td "The text to print if the slot is NIL")) (tr (td (b "value-type")) (td "Sets the data type for the field. See the next section for complete details")) (tr (td (b "inverse")) (td "Sets the name of an automatically generated lookup function based on a key value for this slot")) )) (h3 "Type field") (p "Valid types for a " (span-c pkgbody "hyperobject") "slot along with their coresponding SQL types are listed in the below table.") (table-c "font-family:courier" (tr (td "string") (td "TEXT")) (tr (td (div "(string " (i "n") ")") (div "(varchar " (i "n") ")")) (td "VARCHAR(n)")) (tr (td "(char " (i "n") ")") (td "CHAR(n)")) (tr (td "character") (td "CHAR(1)")) (tr (td (div "float") (div "single-float")) (td "float")) (tr (td "double-float") (td "double")) (tr (td "blob") (td "BLOB"))) (h2 "Subobject field") (p "This field sets up the storage of a slot of hold a cached object or list of objects. A lookup function and the keys to the function are also specified.") (p "The format for the subobject field is:") (p "( keys*)") )) cl-hyperobject-2.12.0/docs/make.lisp0000644000175000017500000000023510667175450016271 0ustar kevinkevin#+cmu (setq ext:*gc-verbose* nil) (asdf:oos 'asdf:load-op :lml) (in-package :lml) (let ((cwd (parse-namestring (lml-cwd)))) (process-dir cwd)) (lml-quit) cl-hyperobject-2.12.0/examples/0000755000175000017500000000000010667175450015351 5ustar kevinkevincl-hyperobject-2.12.0/examples/person.lisp0000644000175000017500000001062710667175450017556 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: hyperobject-example.lisp ;;;; Purpose: Hyperobject Example file ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Oct 2002 ;;;; ;;;; A simple example file for hyperobjects ;;;; ;;;; $Id$ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; ;;;; ************************************************************************* (in-package :hyperobject-user) (defclass person (hyperobject) ((first-name :value-type (varchar 20) :initarg :first-name :accessor first-name :value-constraint stringp :null-allowed nil) (last-name :value-type (varchar 30) :initarg :last-name :accessor last-name :value-constraint stringp :hyperlink find-person-by-last-name :null-allowed nil) (full-name :value-type string :stored nil) (dob :value-type integer :initarg :dob :accessor dob :print-formatter format-date :value-constraint integerp :input-filter convert-to-date) (resume :value-type string :initarg :resume :accessor resume :value-constraint stringp) ;; (addresses :value-type (list-of subobject) :initarg :addresses :accessor addresses)) (addresses :subobject t :initarg :addresses :accessor addresses)) (:metaclass hyperobject-class) (:default-initargs :first-name "" :last-name "" :dob 0 :resume nil) (:default-print-slots first-name last-name dob resume) (:user-name "Person") (:user-name-plural "Persons") (:description "A Person") (:direct-rules (:rule-1 (:dependants (last-name first-name) :volatile full-name) (setf full-name (concatenate 'string first-name " " last-name))))) (defun format-date (ut) (when (typep ut 'integer) (multiple-value-bind (sec min hr day mon year dow daylight-p zone) (decode-universal-time ut) (declare (ignore daylight-p zone)) (format nil "~[Mon~;Tue~;Wed~;Thu~;Fri~;Sat~;Sun~], ~d ~[Jan~;Feb~;Mar~;Apr~;May~;Jun~;Jul~;Aug~;Sep~;Oct~;Nov~;Dec~] ~d ~2,'0d:~2,'0d:~2,'0d" dow day (1- mon) year hr min sec)))) (defclass address (hyperobject) ((title :value-type (varchar 20) :initarg :title :accessor title :value-constraint stringp) (street :value-type (varchar 30) :initarg :street :accessor street :value-constraint stringp) (phones :subobject t :initarg :phones :accessor phones)) (:metaclass hyperobject-class) (:default-initargs :title nil :street nil) (:user-name "Address" "Addresses") (:default-print-slots title street) (:description "An address")) (defclass phone (hyperobject) ((title :value-type (varchar 20) :initarg :title :accessor title :value-constraint stringp) (phone-number :value-type (varchar 16) :initarg :phone-number :accessor phone-number :value-constraint stringp)) (:metaclass hyperobject-class) (:user-name "Phone Number") (:user-name-plural "Phone Numbers") (:default-initargs :title nil :phone-number nil) (:default-print-slots title phone-number) (:description "A phone number")) (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 :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))) (defparameter office (make-instance 'address :title "Office" :street "113 Main St." :phones (list office-phone-1 office-phone-2 office-phone-3))) (defparameter mary (make-instance 'person :first-name "Mary" :last-name "Jackson" :dob (get-universal-time) :addresses (list home office) :resume "Style & Grace")) (format t "~&Text Format~%") (view mary :subobjects t) (format t "~&XML Format with field labels and hyperlinks~%") (view mary :subobjects t :category :xml-link-labels) cl-hyperobject-2.12.0/hyperobject-tests.asd0000644000175000017500000000152710667175450017707 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: hyperobject-tests.asd ;;;; Purpose: ASDF system definitionf for hyperobject testing package ;;;; Author: Kevin M. Rosenberg ;;;; Date Started: Apr 2003 ;;;; ;;;; $Id$ ;;;; ************************************************************************* (defpackage #:hyperobject-tests-system (:use #:asdf #:cl)) (in-package #:hyperobject-tests-system) (defsystem hyperobject-tests :depends-on (:rt :hyperobject) :components ((:file "tests"))) (defmethod perform ((o test-op) (c (eql (find-system :hyperobject-tests)))) (or (funcall (intern (symbol-name '#:do-tests) (find-package '#:regression-test))) (error "test-op failed"))) cl-hyperobject-2.12.0/hyperobject.asd0000644000175000017500000000235610667175450016550 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: hyperobject.asd ;;;; Purpose: ASDF system definition for hyperobject package ;;;; Author: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; ;;;; $Id$ ;;;; ************************************************************************* (defpackage hyperobject-system (:use #:asdf #:cl)) (in-package :hyperobject-system) (defsystem hyperobject :name "hyperobject" :author "Kevin M. Rosenberg " :version "2.7.x" :maintainer "Kevin M. Rosenberg " :licence "BSD-like License" :components ((:file "package") (:file "metaclass" :depends-on ("package")) (:file "mop" :depends-on ("metaclass")) (:file "rules" :depends-on ("mop")) (:file "connect" :depends-on ("mop")) (:file "sql" :depends-on ("connect")) (:file "views" :depends-on ("mop")) (:file "base-class" :depends-on ("views" "sql" "rules")) ) :depends-on (:kmrcl :clsql)) (defmethod perform ((o test-op) (c (eql (find-system :hyperobject)))) (operate 'load-op 'hyperobject-tests) (operate 'test-op 'hyperobject-tests :force t)) cl-hyperobject-2.12.0/metaclass.lisp0000644000175000017500000000242610667175450016404 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: metaclass.lisp ;;;; Purpose: Define options for hyperobject metaclass ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; ;;;; ;;;; $Id$ ;;;; ;;;; This file is Copyright (c) 2000-2006 by Kevin M. Rosenberg ;;;; ************************************************************************* (in-package #:hyperobject) (defparameter *class-options* '(:user-name :default-print-slots :description :version :sql-name :guid :version :direct-functions :direct-views :direct-rules) "List of class options for hyperobjects.") (defparameter *slot-options* '(:value-type :print-formatter :description :short-description :user-name :subobject :hyperlink :hyperlink-parameters :indexed :inverse :unique :sql-name :null-allowed :stored :input-filter :unbound-lookup :value-constraint :void-text :read-only-groups :hidden-groups :unit :compute-cached-value :disable-predicate :view-type :list-of-values) "Slot options that can appear as an initarg") (defparameter *slot-options-no-initarg* '(:ho-type :sql-type :sql-length) "Slot options that do not have an initarg") cl-hyperobject-2.12.0/package.lisp0000644000175000017500000001070110667175450016016 0ustar kevinkevin;;; -*- 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$ ;;;; ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* (in-package #:cl-user) #+sbcl (eval-when (:compile-toplevel :load-toplevel :execute) (if (find-package 'sb-mop) (pushnew :kmr-sbcl-mop cl:*features*) (pushnew :kmr-sbcl-pcl cl:*features*))) #+cmu (eval-when (:compile-toplevel :load-toplevel :execute) (if (eq (symbol-package 'pcl:find-class) (find-package 'common-lisp)) (pushnew :kmr-cmucl-mop cl:*features*) (pushnew :kmr-cmucl-pcl cl:*features*))) (defpackage #:hyperobject (:nicknames #:ho) (:use #:common-lisp #:kmrcl #+kmr-sbcl-mop #:sb-mop #+kmr-cmucl-mop #:mop #+allegro #:mop #+lispworks #:clos #+scl #:clos #+openmcl #:openmcl-mop) (:export #:package #:hyperobject #:hyperobject-class #:hyperobject-class-user-name #:load-all-subobjects #:view #:view-subobjects #:fmt-comma-integer #:processed-queued-definitions #:all-subobjects #:subobjects )) (defpackage #:hyperobject-user (:nicknames #:ho-user) (:use #:hyperobject #:cl #:cl-user)) (eval-when (:compile-toplevel :load-toplevel :execute) (shadowing-import #+allegro '(excl::compute-effective-slot-definition-initargs) #+lispworks '(clos::compute-effective-slot-definition-initargs) #+kmr-sbcl-mop '(sb-pcl::compute-effective-slot-definition-initargs) #+kmr-sbcl-pcl '(sb-pcl:class-of sb-pcl:class-name sb-pcl:class-slots sb-pcl:find-class sb-pcl::standard-class sb-pcl:slot-definition-name sb-pcl::finalize-inheritance sb-pcl::standard-direct-slot-definition sb-pcl::standard-effective-slot-definition sb-pcl::validate-superclass sb-pcl::direct-slot-definition-class sb-pcl::compute-effective-slot-definition sb-pcl::compute-effective-slot-definition-initargs sb-pcl::slot-value-using-class sb-pcl:slot-definition-type sb-pcl:class-prototype sb-pcl:generic-function-method-class sb-pcl:intern-eql-specializer sb-pcl:make-method-lambda sb-pcl:generic-function-lambda-list sb-pcl::class-precedence-list) #+kmr-cmucl-mop '(pcl::compute-effective-slot-definition-initargs) #+kmr-cmucl-pcl '(pcl:class-of pcl:class-name pcl:class-slots pcl:find-class pcl::standard-class pcl::slot-definition-name pcl:finalize-inheritance pcl::standard-direct-slot-definition pcl::standard-effective-slot-definition pcl::validate-superclass pcl:direct-slot-definition-class pcl:compute-effective-slot-definition pcl::compute-effective-slot-definition-initargs pcl::slot-value-using-class pcl:class-prototype pcl:generic-function-method-class pcl:intern-eql-specializer pcl:make-method-lambda pcl:generic-function-lambda-list pcl:slot-definition-type pcl::class-precedence-list) #+clisp '(clos:class-name clos:class-slots clos:find-class clos::standard-class clos::slot-definition-name clos:finalize-inheritance clos::standard-direct-slot-definition clos::standard-effective-slot-definition clos::validate-superclass clos:direct-slot-definition-class clos:effective-slot-definition-class clos:slot-definition-type clos:compute-effective-slot-definition clos::compute-effective-slot-definition-initargs clos::slot-value-using-class clos:class-prototype clos:generic-function-method-class clos:intern-eql-specializer clos:generic-function-lambda-list clos::class-precedence-list) #+scl '(clos::compute-effective-slot-definition-initargs clos::class-prototype clos:slot-definition-type ;; note: make-method-lambda is not fbound ) :hyperobject)) #+sbcl (eval-when (:compile-toplevel :load-toplevel :execute) (if (find-package 'sb-mop) (setq cl:*features* (delete :kmr-sbcl-mop cl:*features*)) (setq cl:*features* (delete :kmr-sbcl-pcl cl:*features*)))) #+cmu (eval-when (:compile-toplevel :load-toplevel :execute) (if (find-package 'mop) (setq cl:*features* (delete :kmr-cmucl-mop cl:*features*)) (setq cl:*features* (delete :kmr-cmucl-pcl cl:*features*)))) cl-hyperobject-2.12.0/rules.lisp0000644000175000017500000000560710667175450015566 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: rules.lisp ;;;; Purpose: Slot and Class rules ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; ;;;; $Id$ ;;;; ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* (in-package #:hyperobject) ;;; Slot accessor and class rules (defclass rule () ((name :initarg :name :initform nil :accessor name) (dependants :initarg :dependants :initform nil :accessor dependants) (volatile :initarg :volatile :initform nil :accessor volatile) (access-slots :initarg :access-slots :initform nil :accessor access-slots) (source-code :initarg :source-code :initform nil :accessor source-code) (func :initform nil :initarg :func :accessor func))) (defun compile-rule (source-code dependants volatile cl) (declare (ignore cl)) (let ((access (appendnew dependants volatile))) (compile nil (eval `(lambda (obj) (when (every #'(lambda (x) (slot-boundp obj x)) (quote ,dependants)) (with-slots ,access obj ,@source-code))))))) (defun finalize-rules (cl) (setf (rules cl) (loop for rule in (direct-rules cl) collect (destructuring-bind (name (&key dependants volatile) &rest source-code) rule (setf dependants (mklist dependants) volatile (mklist volatile)) (make-instance 'rule :name name :dependants dependants :volatile volatile :source-code source-code :access-slots (appendnew dependants volatile) :func (compile-rule source-code dependants volatile cl)))))) (defun fire-class-rules (cl obj slot) "Fire all class rules. Called after a slot is modified." (let ((name (slot-definition-name slot))) (dolist (rule (rules cl)) (when (find name (dependants rule)) (cmsg-c :debug "firing rule: ~W" (source-code rule)) (funcall (func rule) obj))))) #+ho-svuc (defmethod (setf slot-value-using-class) :around (new-value (cl hyperobject-class) obj (slot hyperobject-esd)) #+ignore (cmsg-c :verbose "Setf slot value: class: ~s, obj: ~s, slot: ~s, value: ~s" cl (class-of obj) slot new-value) (let ((func (esd-value-constraint slot))) (cond ((and func (not (funcall func new-value))) (warn "Rejected change to value of slot ~a of object ~a" (slot-definition-name slot) obj) (slot-value obj (slot-definition-name slot))) (t (prog1 (call-next-method) (when (direct-rules cl) (fire-class-rules cl obj slot))))))) cl-hyperobject-2.12.0/run-tests.lisp0000644000175000017500000000242010667175450016366 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: run-tests.lisp ;;;; Purpose: Regression suite for hyperobject ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; ;;;; $Id$ ;;;; ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* (defpackage #:run-tests (:use #:cl)) (in-package #:run-tests) (require 'rt) (require 'kmrcl) (load "hyperobject.asd") (load "hyperobject-tests.asd") (asdf:oos 'asdf:test-op 'hyperobject) (defun quit (&optional (code 0)) "Function to exit the Lisp implementation. Copied from CLOCC's QUIT function." #+allegro (excl:exit code) #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code) #+(or cmu scl) (ext:quit code) #+cormanlisp (win32:exitprocess code) #+gcl (lisp:bye code) #+lispworks (lw:quit :status code) #+lucid (lcl:quit code) #+sbcl (sb-ext:quit :unix-status (typecase code (number code) (null 0) (t 1))) #+mcl (ccl:quit code) #-(or allegro clisp cmu scl cormanlisp gcl lispworks lucid sbcl mcl) (error 'not-implemented :proc (list 'quit code))) (quit) cl-hyperobject-2.12.0/sql.lisp0000644000175000017500000001564210667175450015233 0ustar kevinkevin;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: sql.lisp ;;;; Purpose: SQL Generation functions for Hyperobject ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; ;;;; $Id$ ;;;; ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* (in-package #:hyperobject) ;;;; Metaclass initialization commands (defun finalize-sql (cl) (setf (slot-value cl 'drop-table-cmd) (generate-drop-table-cmd (slot-value cl 'sql-name))) (let ((esds (class-slots cl))) (setf (slot-value cl 'create-table-cmd) (generate-create-table-cmd cl (remove-if #'(lambda (esd) (null (esd-stored esd))) esds))) (setf (slot-value cl 'create-indices-cmds) (generate-create-indices-cmds (sql-name cl) esds)) (dolist (esd esds) (when (slot-value esd 'inverse) (define-inverse cl esd)))) ) (defun define-inverse (class esd) "Define an inverse function for a slot" (let ((inverse (slot-value esd 'inverse))) (when inverse (eval `(defun ,inverse (obj) (format t "~&Finding key: ~S for class ~S ~%" obj ,class) ;; create inverse function )) )) ) (defun generate-create-table-cmd (cl esds) (with-output-to-string (s) (format s "CREATE TABLE ~A (~{~A~^, ~})" (slot-value cl 'sql-name) (loop for esd in esds collect (concatenate 'string (slot-value esd 'sql-name) " " (sql-type-to-field-string (slot-value esd 'sql-type) (slot-value esd 'sql-length))))))) (defun sql-type-to-field-string (type length) (ecase type (:string (cond ((null length) "LONGTEXT") ((< length 8) (format nil "CHAR(~d)" length)) (t (format nil "VARCHAR(~d)" length)))) (:varchar (cond ((null length) "LONGTEXT") (t (format nil "VARCHAR(~d)" length)))) (:text "LONGTEXT") (:datetime "VARCHAR(20)") (:char (unless length (setq length 1)) (format nil "CHAR(~D)" length)) ((or :fixnum :integer) "INTEGER") (:boolean "CHAR(1)") (:long-integer "BIGINT") ((or :short-float :float) "SINGLE") (:long-float "DOUBLE"))) (defun generate-drop-table-cmd (table-name) (format nil "DROP TABLE ~a" table-name)) (defun generate-create-indices-cmds (table-name slots) (let (indices) (dolist (slot slots) (when (slot-value slot 'indexed) (let ((sql-name (slot-value slot 'sql-name))) (push (sql-cmd-index table-name sql-name (slot-value slot 'unique)) indices)))) indices)) (defun sql-cmd-index (table field unique) (let ((*print-circle* nil)) (format nil "CREATE ~AINDEX ~A ON ~A(~A)" (if unique "UNIQUE " "") (sql-index-name table field) table field))) (defun sql-index-name (table field) (format nil "~A_~A" table field)) ;;;; Runtime Commands (defgeneric sql-create (cl)) (defmethod sql-create (cl) (with-sql-connection (conn) (sql-execute (slot-value cl 'create-table-cmd) conn) (dolist (cmd (slot-value cl 'create-indices-cmds)) (sql-execute cmd conn)) (values))) (defgeneric sql-drop (cl)) (defmethod sql-drop (cl) (mutex-sql-execute (slot-value cl 'drop-table-cmd)) (values)) #| (defmethod sql-insert (obj) (mutex-sql-execute (format nil "INSERT INTO ~a (~a) VALUES (~a)" (sql-name self) (sql-cmd-field-names self) (format-values self)))) (defmethod sql-select (obj lisp-name key) (let ((tuple (car (mutex-sql-query (format nil "SELECT ~a FROM ~a WHERE ~a=~a" (sql-cmd-field-names self) (sql-name self) (inverse-field-name self) key))))) (when tuple (format t "process returned fields")))) (defun format-values (self) (let ((values "") (fields (fields self))) (dolist (field fields) (unless (eq field (car fields)) (string-append values ",")) (let ((name (car field))) (with-key-value-list (key value (rest field)) (when (eq key :type) (string-append values (ecase value ((:fixnum :bigint :short-float :double-float) (write-to-string (slot-value self name))) ((:string :text) (format nil "'~a'" (add-sql-quotes (slot-value self name)))))))))) values)) (defun inverse-field-string (fields) (let (inverse) (dolist (field fields) (let ((name-string (write-to-string (car field)))) (with-key-value-list (key value (rest field)) (when (eq key :inverse) (setq inverse value))))) (when inverse (write-to-string inverse)))) (defun row-field-string (fields) (let ((names "")) (dolist (field fields) (unless (eq field (car fields)) (string-append names ",")) (string-append names (lisp-name-to-sql-name (car field)))) names)) (defun parse-fields (table-name fields) (let (class-fields) (dolist (field fields) (let* ((fname (car field)) (name-string (write-to-string fname)) (initarg (intern name-string :keyword))concat-symbol (def (list fname)) (options (rest field))) (with-key-value-list (key value options) (case key (:type (setq def (nconc def (list :type (ecase value (:string 'string) (:fixnum 'fixnum) (:long-integer 'integer) (:short-float 'short-float) (:long 'long-float) (:text 'string)))))))) (setq def (nconc def (list :initarg initarg :accessor (concat-symbol (write-to-string table-name) "-" (write-to-string fname))))) (push def class-fields))) class-fields)) ||# cl-hyperobject-2.12.0/tests.lisp0000644000175000017500000001340410667175450015570 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: hyperobject-tests.lisp ;;;; Purpose: Hyperobject tests file ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2003 ;;;; ;;;; $Id$ ;;;; ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* (defpackage #:hyperobject-tests (:use #:hyperobject #:cl #:rtest #:kmrcl)) (in-package #:hyperobject-tests) (defvar *now* (get-universal-time)) (defun get-now () *now*) (defclass person (hyperobject) ((first-name :initarg :first-name :accessor first-name :value-type (varchar 20) :value-constraint stringp :null-allowed nil) (last-name :initarg :last-name :accessor last-name :value-type (varchar 30) :value-constraint stringp :hyperlink find-person-by-last-name :hyperlink-parameters (("narrow" . "yes")) :null-allowed nil) (full-name :value-type string :stored nil) (dob :initarg :dob :accessor dob :value-type integer :print-formatter date-string :value-constraint integerp :input-filter convert-to-date) (resume :initarg :resume :accessor resume :value-type string :value-constraint stringp) ;; (addresses :value-type (list-of subobject) :initarg :addresses :accessor addresses)) (addresses :initarg :addresses :accessor addresses :subobject t) (create-time :accessor create-time :compute-cached-value (get-now))) (:metaclass hyperobject-class) (:default-initargs :first-name "" :last-name "" :dob 0 :resume nil) (:default-print-slots first-name last-name dob resume) (:user-name "Person") (:description "A Person") (:direct-rules (:rule-1 (:dependants (last-name first-name) :volatile full-name) (setf full-name (concatenate 'string first-name " " last-name))))) (defclass address (hyperobject) ((title :initarg :title :accessor title :value-type (varchar 20) :value-constraint stringp) (street :initarg :street :accessor street :value-type (varchar 30) :value-constraint stringp) (phones :initarg :phones :accessor phones :subobject t) (years-at-address :initarg :years-at-address :value-type fixnum :accessor years-at-address :value-constraint integerp)) (:metaclass hyperobject-class) (:default-initargs :title nil :street nil) (:user-name "Address" "Addresses") (:default-print-slots title street years-at-address) (:description "An address")) (defclass phone (hyperobject) ((title :initarg :title :accessor title :value-type (varchar 20) :value-constraint stringp) (phone-number :initarg :phone-number :accessor phone-number :value-type (varchar 16) :value-constraint stringp :hyperlink search-phone-number)) (:metaclass hyperobject-class) (:user-name "Phone Number") (:default-initargs :title nil :phone-number nil) (:default-print-slots title phone-number) (:description "A phone number")) (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 :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" :years-at-address 10 :phones (list home-phone-1 home-phone-2))) (defparameter office (make-instance 'address :title "Office" :street "113 Main St." :years-at-address 5 :phones (list office-phone-1 office-phone-2 office-phone-3))) (defparameter mary (make-instance 'person :first-name "Mary" :last-name "Jackson" :dob (encode-universal-time 1 2 3 4 5 2000) :addresses (list home office) :resume "Style & Grace")) (defun view-to-string (obj &rest args) (with-output-to-string (strm) (apply #'view obj :stream strm args))) (rem-all-tests) (deftest :p1 (view-to-string mary :vid :compact-text) "Person: Mary Jackson Thu, 4 May 2000 03:02:01 Style & Grace ") (deftest :p2 (view-to-string mary :subobjects t :vid :compact-text) "Person: Mary Jackson Thu, 4 May 2000 03:02:01 Style & Grace Addresses: Home 321 Shady Lane 10 Phone Numbers: Voice 367-9812 Fax 367-9813 Office 113 Main St. 5 Phone Numbers: Main line 123-0001 Staff line 123-0002 Fax 123-0005 ") (deftest :p3 (view-to-string mary :vid :compact-text-labels) "Person: first-name Mary last-name Jackson dob Thu, 4 May 2000 03:02:01 resume Style & Grace ") (deftest :p4 (view-to-string mary :vid :compact-text) "Person: Mary Jackson Thu, 4 May 2000 03:02:01 Style & Grace ") (deftest :cv1 (years-at-address home) 10) (deftest :cv2 (years-at-address office) 5) (deftest :cv3 (equal (create-time mary) *now*) t) (deftest :s1 (slot-value (class-of mary) 'ho::user-name) "Person") (deftest :s2 (slot-value (class-of mary) 'ho::user-name-plural) "Persons") (deftest :s3 (slot-value (class-of home) 'ho::user-name-plural) "Addresses") (deftest :s4 (slot-value (class-of mary) 'ho::description) "A Person") cl-hyperobject-2.12.0/views.lisp0000644000175000017500000007777211605661254015600 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: views.lisp ;;;; Purpose: View methods for Hyperobjects ;;;; Author: Kevin M. Rosenberg ;;;; Created: Apr 2000 ;;;; ;;;; $Id$ ;;;; ;;;; This file is Copyright (c) 2000-2004 by Kevin M. Rosenberg ;;;; ************************************************************************* (in-package #:hyperobject) (defclass object-view () ((object-class :initform nil :initarg :object-class :accessor object-class :documentation "Class of object to be viewed.") (slots :initform nil :initarg :slots :accessor slots :documentation "List of effective slots for object to be viewed.") (id :initform nil :initarg :id :accessor id :documentation "id for this view.") (source-code :initform nil :initarg :source-code :accessor source-code :documentation "Source code for generating view.") (country-language :initform :en :initarg :country-language :documentation "Country's Language for this view.") (printer :initform nil :initarg :printer :accessor printer :documentation "default function that prints the object") ;; (file-start-str :type (or string null) :initform nil :initarg :file-start-str :accessor file-start-str) (file-end-str :type (or string null) :initform nil :initarg :file-end-str :accessor file-end-str) (list-start-printer :type (or string function null) :initform nil :initarg :list-start-printer :accessor list-start-printer) (list-start-indent :initform nil :initarg :list-start-indent :accessor list-start-indent) (list-end-printer :type (or string function null) :initform nil :initarg :list-end-printer :accessor list-end-printer) (list-end-indent :initform nil :initarg :list-end-indent :accessor list-end-indent) (obj-start-printer :type (or string function null) :initform nil :initarg :obj-start-printer :accessor obj-start-printer) (obj-start-indent :initform nil :initarg :obj-start-indent :accessor obj-start-indent) (obj-end-printer :type (or string function null) :initform nil :initarg :obj-end-printer :accessor obj-end-printer) (obj-end-indent :initform nil :initarg :obj-end-indent :accessor obj-end-indent) (subobj-start-printer :type (or string function null) :initform nil :initarg :subobj-start-printer :accessor subobj-start-printer) (subobj-start-indent :initform nil :initarg :subobj-start-indent :accessor subobj-start-indent) (subobj-end-printer :type (or string function null) :initform nil :initarg :subobj-end-printer :accessor subobj-end-printer) (subobj-end-indent :initform nil :initarg :subobj-end-indent :accessor subobj-end-indent) (obj-data-indent :initform nil :initarg :obj-data-indent :accessor obj-data-indent) (obj-data-printer :type (or function null) :initform nil :initarg :obj-data-printer :accessor obj-data-printer) (obj-data-print-code :type (or function list null) :initform nil :initarg :obj-data-print-code :accessor obj-data-print-code) (obj-data-start-printer :type (or function string null) :initform nil :initarg :obj-data-start-printer :accessor obj-data-start-printer) (obj-data-end-printer :type (or string null) :initform nil :initarg :obj-data-end-printer :accessor obj-data-end-printer) (indenter :type (or function null) :initform nil :accessor indenter :documentation "Function that performs hierarchical indenting") (link-slots :type list :initform nil :documentation "List of slot names that have hyperlinks" :accessor link-slots) (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 "meta-search.html") (:documentation "View class for a hyperobject")) (defun get-default-view-id (obj-cl) (aif (views obj-cl) (id (car it)) :compact-text)) (defun find-view-id-in-class-precedence (obj-cl vid) "Looks for a view in class and parent classes" (when (typep obj-cl 'hyperobject-class) (aif (find vid (views obj-cl) :key #'id :test #'eq) it (let (cpl) (handler-case (setq cpl (class-precedence-list obj-cl)) (error (e) (declare (ignore e)) ;; can't get cpl unless class finalized (make-instance (class-name obj-cl)) (setq cpl (class-precedence-list obj-cl)))) (find-view-id-in-class-precedence (second cpl) vid))))) (defun get-view-id (obj vid &optional slots) "Find or make a category view for an object" (let ((obj-cl (class-of obj))) (unless vid (setq vid (get-default-view-id obj-cl))) (aif (find-view-id-in-class-precedence obj-cl vid) it (let ((view (make-instance 'object-view :object-class (class-name obj-cl) :id vid :slots slots))) (push view (views obj-cl)) view)))) ;;;; ************************************************************************* ;;;; Metaclass Intialization ;;;; ************************************************************************* (defun finalize-views (cl) "Finalize all views that are given on a objects initialization" (unless (default-print-slots cl) (setf (default-print-slots cl) (mapcar #'slot-definition-name (class-slots cl)))) (setf (views cl) (loop for view-def in (direct-views cl) collect (make-object-view cl view-def)))) (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" (cond ((typep view-def 'object-view) view-def) ((eq view-def :default) (make-instance 'object-view :object-class (class-name cl) :id :compact-text)) ((consp view-def) (make-instance 'object-view :object-class (class-name cl) :id (getf view-def :id) :slots (getf view-def :slots) :source-code (getf view-def :source-code))) (t (error "Invalid parameter to make-object-view: ~S" view-def)))) (defmethod initialize-instance :after ((self object-view) &rest initargs &key &allow-other-keys) (declare (ignore initargs)) (initialize-view self)) (defun initialize-view (view) "Calculate all view slots for a hyperobject class" (let ((obj-cl (find-class (object-class view)))) (cond ((source-code view) (initialize-view-by-source-code view)) ((id view) (initialize-view-by-id obj-cl view)) (t (setf (id view) :compact-text) (initialize-view-by-id obj-cl view))))) (defun initialize-view-by-source-code (view) "Initialize a view based upon a source code" (let* ((source-code (source-code view)) (printer `(lambda (,(intern (symbol-name '#:self) (symbol-package (object-class view))) ,(intern (symbol-name '#:s) (symbol-package (object-class view)))) (declare (ignorable ,(intern (symbol-name '#:self) (symbol-package (object-class view))) ,(intern (symbol-name '#:s) (symbol-package (object-class view))))) (with-slots ,(slots view) ,(intern (symbol-name '#:self) (symbol-package (object-class view))) ,@source-code)))) (setf (printer view) (compile nil (eval printer))))) (defmacro write-simple (v s) `(typecase ,v (string (write-string ,v ,s)) (fixnum (write-fixnum ,v ,s)) (symbol (write-string (symbol-name ,v) ,s)) (t (write-string (write-to-string ,v) ,s)))) (defun write-ho-value (obj name type formatter cdata strm) (declare (ignorable type)) (let* ((slot-data (slot-value obj name)) (fmt-data (if formatter (funcall formatter slot-data) slot-data))) (if cdata (write-cdata fmt-data strm) (write-simple fmt-data strm)))) (defun ppfc-html (title name type formatter cdata print-func) (vector-push-extend '(write-string "" s) print-func) (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func) (vector-push-extend '(write-string "" s) print-func)) (defun ppfc-xml (tag name type formatter cdata print-func) (vector-push-extend '(write-char #\< s) print-func) (vector-push-extend `(write-string ,tag s) print-func) (vector-push-extend '(write-char #\> s) print-func) (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func) (vector-push-extend '(write-string " s) print-func)) (defun ppfc-display-table (title name type formatter cdata print-func) (vector-push-extend '(write-string "" s) print-func) (ppfc-html title name type formatter cdata print-func) (vector-push-extend '(write-string "" s) print-func)) (defun ppfc-html-labels (label name type formatter cdata print-func) (vector-push-extend '(write-string "" s) print-func) (vector-push-extend `(when (stringp ,label) (write-string ,label s)) print-func) (vector-push-extend '(write-string " " s) print-func) (ppfc-html label name type formatter cdata print-func)) (defun ppfc-xhtml-labels (label tag name type formatter cdata print-func) (vector-push-extend '(write-string "" s) print-func) (vector-push-extend `(when (stringp ,label) (write-string ,label s)) print-func) (vector-push-extend '(write-string " " s) print-func) (ppfc-html tag name type formatter cdata print-func)) (defun ppfc-xml-labels (label tag name type formatter cdata print-func) (vector-push-extend '(write-string " " s) print-func) (ppfc-xml tag name type formatter cdata print-func)) (defun ppfc-html-link (name type formatter cdata nlink print-func) (declare (fixnum nlink)) (vector-push-extend '(write-char #\< s) print-func) (vector-push-extend `(when (stringp (nth ,(+ nlink nlink) links)) (write-string (nth ,(+ nlink nlink) links) s)) print-func) (vector-push-extend '(write-char #\> s) print-func) (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func) (vector-push-extend '(write-string " s) print-func)) (defun ppfc-html-link-labels (label name type formatter cdata nlink print-func) (vector-push-extend '(write-string "" s) print-func) (vector-push-extend `(when (stringp ,label) (write-string ,label s)) print-func) (vector-push-extend '(write-string " " s) print-func) (ppfc-html-link name type formatter cdata nlink print-func)) (defun push-print-fun-code (vid slot nlink print-func) (let* ((formatter (esd-print-formatter slot)) (name (slot-definition-name slot)) (user-name (esd-user-name slot)) (xml-user-name (escape-xml-string user-name)) (xml-tag (escape-xml-string user-name)) (type (slot-definition-type slot)) (cdata (not (null (and (in vid :xml :xhtml :xml-link :xhtml-link :xml-labels :ie-xml-labels :xhtml-link-labels :xml-link-labels :ie-xml-link :ie-xml-link-labels) (or formatter (lisp-type-is-a-string type)))))) (hyperlink (esd-hyperlink slot))) (case vid (:compact-text (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)) (:compact-text-labels (vector-push-extend `(write-string ,user-name s) print-func) (vector-push-extend '(write-char #\space s) print-func) (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)) ((or :html :xhtml) (ppfc-html user-name name type formatter cdata print-func)) (:xml (ppfc-xml xml-tag name type formatter cdata print-func)) (:html-labels (ppfc-html-labels user-name name type formatter cdata print-func)) (:xhtml-labels (ppfc-xhtml-labels xml-user-name user-name name type formatter cdata print-func)) ((:display-table :display-table-labels) (ppfc-display-table user-name name type formatter cdata print-func)) (:xml-labels (ppfc-xml-labels xml-user-name xml-tag name type formatter cdata print-func)) ((or :html-link :xhtml-link) (if hyperlink (ppfc-html-link name type formatter cdata nlink print-func) (ppfc-html user-name name type formatter cdata print-func))) ((or :xml-link :ie-xml-link) (if hyperlink (ppfc-html-link name type formatter cdata nlink print-func) (ppfc-xml xml-tag name type formatter cdata print-func))) (:html-link-labels (if hyperlink (ppfc-html-link-labels user-name name type formatter cdata nlink print-func) (ppfc-html-labels user-name name type formatter cdata print-func))) (:xhtml-link-labels (if hyperlink (ppfc-html-link-labels xml-user-name name type formatter cdata nlink print-func) (ppfc-xhtml-labels xml-tag user-name name type formatter cdata print-func))) ((or :xml-link-labels :ie-xml-link-labels) (if hyperlink (ppfc-html-link-labels xml-user-name name type formatter cdata nlink print-func) (ppfc-xml-labels xml-tag user-name name type formatter cdata print-func)))))) (defun view-has-links-p (view) (in (id view) :html-link :xhtml-link :xml-link :ie-xml-link :html-link-labels :xhtml-link-labels :xml-link-labels :ie-xml-link-labels)) (defun creatable-view-id-p (obj-cl vid) "Returns T if a view id can be created for this class" (declare (ignore obj-cl)) (in vid :compact-text :compact-text-labels :html :html-labels :html-link-labels :xhtml :xhtml-labels :xhtml-link-labels :xhtml-link :html-link :xml :xml-labels :xml-link :ie-xml-link :xml-link-labels :ie-xml-link-labels :display-table :display-table-labels :edit-table :edit-table-labels)) (defun initialize-view-by-id (obj-cl view) "Initialize a view based upon a preset vid" (unless (creatable-view-id-p obj-cl (id view)) (error "Unable to automatically create view id ~A" (id view))) (unless (slots view) (setf (slots view) (default-print-slots obj-cl))) (let ((links '()) (print-func (make-array 20 :fill-pointer 0 :adjustable t))) (do* ((slots (slots view) (cdr slots)) (slot-name (car slots) (car slots)) (slot (find-slot-by-name obj-cl slot-name) (find-slot-by-name obj-cl slot-name))) ((null slots)) (unless slot (error "Slot ~A is not found in class ~S" slot-name obj-cl)) (push-print-fun-code (id view) slot (length links) print-func) (when (> (length slots) 1) (vector-push-extend '(write-char #\space s) print-func)) (when (and (view-has-links-p view) (esd-hyperlink slot)) (push (slot-definition-name slot) links))) (vector-push-extend 'x print-func) ;; return object (setf (obj-data-print-code view) `(lambda (x s links) (declare (ignorable s links)) ,@(map 'list #'identity print-func))) (setf (obj-data-printer view) (compile nil (eval (obj-data-print-code view)))) (setf (link-slots view) (nreverse links))) (finalize-view-by-id view) view) (defun finalize-view-by-id (view) (case (id view) ((or :compact-text :compact-text-labels) (initialize-text-view view)) ((or :html :html-labels) (initialize-html-view view)) ((or :xhtml :xhtml-labels) (initialize-xhtml-view view)) ((or :xml :xml-labels) (initialize-xml-view view)) ((or :html-link :html-link-labels) (initialize-html-view view) (setf (link-href-start view) "a href=") (setf (link-href-end view) "a") (setf (link-ampersand view) "&")) ((or :xhtml-link :xhtml-link-labels) (initialize-xhtml-view view) (setf (link-href-start view) "a href=") (setf (link-href-end view) "a") (setf (link-ampersand view) "&")) ((or :display-table :display-table-labels :edit-tables) (initialize-table-view view) (when (in (id view) :display-table-labels :edit-table-labels) (setf (list-start-printer view) #'table-label-list-start-func)) (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 (link-href-start view) "xmllink xlink:type=\"simple\" xlink:href=") (setf (link-href-end view) "xmllink") (setf (link-ampersand view) "&")) ((or :ie-xml-link :ie-xml-link-labels) (initialize-xml-view view) (setf (link-href-start view) "html:a href=") (setf (link-href-end view) "html:a") (setf (link-ampersand view) "&")))) ;;;; ************************************************************************* ;;;; View Data Format Section ;;;; ************************************************************************* (defun class-name-of (obj) (string-downcase (class-name (class-of obj)))) (defvar +newline-string+ (format nil "~%")) (defun write-user-name-maybe-plural (obj nitems strm) (write-string (if (> nitems 1) (hyperobject-class-user-name-plural obj) (hyperobject-class-user-name obj)) strm)) (defun initialize-text-view (view) (setf (list-start-printer view) (compile nil (eval '(lambda (obj nitems indent strm) (declare (ignore indent)) (write-user-name-maybe-plural obj nitems strm) (write-char #\: strm) (write-char #\Newline strm))))) (setf (list-start-indent view) t) (setf (obj-data-indent view) t) (setf (obj-data-end-printer view) +newline-string+) (setf (indenter view) #'indent-spaces)) (defun html-list-start-func (obj nitems indent strm) (write-string "
" strm) (write-user-name-maybe-plural obj nitems strm) (write-string "
" strm) (write-char #\newline strm) (write-string "
    " strm) (write-char #\newline strm)) (defun initialize-html-view (view) (initialize-text-view view) (setf (indenter view) #'indent-spaces) (setf (file-start-str view) (format nil "~%")) (setf (file-end-str view) (format nil "~%")) (setf (list-start-indent view) t) (setf (list-start-printer view) #'html-list-start-func) (setf (list-end-printer view) (format nil "
~%")) (setf (list-end-indent view) t) (setf (obj-start-indent view) nil) (setf (obj-start-printer view) "
  • ") (setf (obj-end-indent view) nil) (setf (obj-end-printer view) (format nil "
    • ~%")) (setf (obj-data-end-printer view) nil) (setf (obj-data-indent view) nil)) (defun xhtml-list-start-func (obj nitems indent strm) (write-string "
    " strm) (write-user-name-maybe-plural obj nitems strm) (write-string "
    " strm) (write-string "
    " strm) (write-char #\newline strm)) (defun table-list-start-func (obj nitems indent strm) (write-string "
    " strm) (write-user-name-maybe-plural obj nitems strm) (write-string "
    " strm) (write-char #\newline strm) (write-string "" strm) (write-string "" strm) (write-char #\newline strm)) (defun table-label-list-start-func (obj nitems indent strm) (write-string "
    " strm) (write-user-name-maybe-plural obj nitems strm) (write-string "
    " strm) (write-char #\newline strm) (write-string "
    " strm) (write-string "" strm) (dolist (slot (default-print-slots (class-of obj))) (write-string "" strm)) (write-string "" strm) (write-char #\newline strm) (write-string "" strm) (write-char #\newline strm)) (defun html-obj-start (obj indent strm) (declare (ignore obj indent)) (write-string "
    " strm)) (defun initialize-xhtml-view (view) (initialize-text-view view) (setf (indenter view) #'indent-spaces) (setf (file-start-str view) (format nil "~%")) (setf (file-end-str view) (format nil "~%")) (setf (list-start-indent view) nil) (setf (list-start-printer view) #'xhtml-list-start-func) (setf (list-end-printer view) (format nil "
    ~%")) (setf (list-end-indent view) nil) (setf (obj-start-indent view) nil) (setf (obj-start-printer view) #'html-obj-start) (setf (obj-end-printer view) (format nil "~%")) (setf (obj-data-indent view) nil)) (defun initialize-table-view (view) (initialize-text-view view) (setf (indenter view) #'indent-spaces) (setf (file-start-str view) (format nil "~%")) (setf (file-end-str view) (format nil "~%")) (setf (list-start-indent view) nil) (setf (list-start-printer view) #'table-list-start-func) (setf (list-end-printer view) (format nil "~%
    " strm) (write-string (write-to-string slot) strm) (write-string "
    ~%")) (setf (list-end-indent view) nil) (setf (obj-start-indent view) nil) (setf (obj-start-printer view) #'html-obj-start) (setf (obj-start-printer view) (format nil "")) (setf (obj-end-printer view) (format nil "~%")) (setf (obj-data-indent view) nil)) (defun xmlformat-list-end-func (x strm) (write-string "" strm) (write-char #\newline strm)) (defun xmlformat-list-start-func (x nitems indent strm) (declare (ignore indent)) (write-char #\< strm) (write-string (class-name-of x) strm) (write-string "list>" strm) (write-user-name-maybe-plural x nitems strm) (write-string ":" strm) (write-char #\newline strm)) (defun initialize-xml-view (view) (let ((name (string-downcase (symbol-name (object-class view))))) (setf (file-start-str view) "") ; (std-xml-header) (setf (list-start-indent view) t) (setf (list-start-printer view) #'xmlformat-list-start-func) (setf (list-end-indent view) t) (setf (list-end-printer view) #'xmlformat-list-end-func) (setf (obj-start-printer view) (format nil "<~(~a~)>" name)) (setf (obj-start-indent view) t) (setf (obj-end-printer view) (format nil "~%" name)) (setf (subobj-end-printer view) (format nil "~%" name)) (setf (subobj-end-indent view) nil) (setf (obj-data-indent view) nil))) ;;; File Start and Ends (defun fmt-file-start (view strm) (awhen (file-start-str view) (write-string it strm))) (defun fmt-file-end (view strm) (awhen (file-end-str view) (write-string it strm))) ;;; List Start and Ends (defun fmt-list-start (obj view strm indent num-items) (when (list-start-indent view) (awhen (indenter view) (funcall it indent strm))) (awhen (list-start-printer view) (if (stringp it) (write-string it strm) (funcall it obj num-items indent strm)))) (defun fmt-list-end (obj view strm indent num-items) (declare (ignore num-items)) (when (list-end-indent view) (awhen (indenter view) (funcall it indent strm))) (awhen (list-end-printer view) (if (stringp it) (write-string it strm) (funcall it obj strm)))) ;;; Object Start and Ends (defun fmt-obj-start (obj view strm indent) (when (obj-start-indent view) (awhen (indenter view) (funcall it indent strm))) (awhen (obj-start-printer view) (if (stringp it) (write-string it strm) (funcall it obj indent strm)))) (defun fmt-obj-end (obj view strm indent) (when (obj-end-indent view) (awhen (indenter view) (funcall it indent strm))) (awhen (obj-end-printer view) (if (stringp it) (write-string it strm) (funcall it obj strm)))) (defun fmt-subobj-start (obj view strm indent) (when (subobj-start-indent view) (awhen (indenter view) (funcall it indent strm))) (awhen (subobj-start-printer view) (if (stringp it) (write-string it strm) (funcall it obj indent strm)))) (defun fmt-subobj-end (obj view strm indent) (when (subobj-end-indent view) (awhen (indenter view) (funcall it indent strm))) (awhen (subobj-end-printer view) (if (stringp it) (write-string it strm) (funcall it obj strm)))) ;;; Object Data (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) (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 link-printer) (awhen (obj-data-start-printer view) (if (stringp it) (write-string it strm) (funcall it obj strm))) (when (obj-data-indent view) (awhen (indenter view) (funcall it indent strm))) (if (link-slots view) (fmt-obj-data-with-link obj view strm refvars link-printer) (fmt-obj-data-plain obj view strm)) (awhen (obj-data-end-printer view) (if (stringp it) (write-string it strm) (funcall it obj strm)))) (defun fmt-obj-data-plain (obj view strm) (awhen (obj-data-printer view) (funcall it obj strm nil))) (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) link-printer) refvalues) (push (make-link-end obj view name) refvalues))) (funcall (obj-data-printer view) obj strm (nreverse refvalues)))) (defun obj-data (obj view) "Returns the objects data as a string. Used by common-graphics outline function" (with-output-to-string (s) (fmt-obj-data-plain obj view s))) ;;; Display method for objects (defun load-all-subobjects (objs) "Load all subobjects if they have not already been loaded." (dolist (obj (mklist objs)) (dolist (subobj (hyperobject-class-subobjects obj)) (awhen (slot-value obj (name-slot subobj)) (load-all-subobjects it)))) objs) (defun view-subobjects (obj strm &optional vid (indent 0) filter subobjects refvars link-printer) (when (hyperobject-class-subobjects obj) (dolist (subobj (hyperobject-class-subobjects obj)) (aif (slot-value obj (name-slot subobj)) (view-hyperobject it (get-view-id (car (mklist it)) vid) strm vid (1+ indent) filter subobjects refvars link-printer))))) (defun view-hyperobject (objs view strm &optional vid (indent 0) filter subobjects refvars link-printer) "Display a single or list of hyperobject-class instances and their subobjects" (let-when (objlist (mklist objs)) (let ((nobjs (length objlist)) (*print-pretty* nil) (*print-circle* nil) (*print-escape* nil) (*print-readably* nil) (*print-length* nil) (*print-level* nil)) (fmt-list-start (car objlist) view strm indent nobjs) (dolist (obj objlist) (awhen (printer view) (funcall it obj strm)) (unless (and filter (not (funcall filter obj))) (fmt-obj-start obj view strm indent) (fmt-obj-data obj view strm (1+ indent) refvars link-printer) (fmt-obj-end obj view strm indent) (if subobjects (progn (fmt-subobj-start obj view strm indent) (view-subobjects obj strm vid indent filter subobjects refvars link-printer) (fmt-subobj-end obj view strm indent)) (fmt-subobj-start obj view strm indent)))) (fmt-list-end (car objlist) view strm indent nobjs))) objs) (defun view (objs &key (stream *standard-output*) vid view filter subobjects refvars file-wrapper link-printer) "EXPORTED Function: prints hyperobject-class objects. Calls view-hyperobject" (let-when (objlist (mklist objs)) (unless view (setq view (get-view-id (car objlist) vid))) (when file-wrapper (fmt-file-start view stream)) (view-hyperobject objlist view stream vid 0 filter subobjects refvars link-printer) (when file-wrapper (fmt-file-end view stream))) objs) ;;; Misc formatting (defun fmt-comma-integer (i) (format nil "~:d" i)) cl-hyperobject-2.12.0/base-class.lisp0000644000175000017500000000147211345753571016445 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: base-class.lisp ;;;; Purpose: Definition of basic hyperobject class ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; ;;;; $Id$ ;;;; ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* (in-package #:hyperobject) (defclass hyperobject () () (:metaclass hyperobject-class) (:description "Basic hyperobject class")) (defmethod print-object ((obj hyperobject) s) (print-unreadable-object (obj s :type t :identity nil) (funcall (obj-data-printer (get-view-id obj :compact-text)) obj s nil))) cl-hyperobject-2.12.0/mop.lisp0000644000175000017500000005537611605661254015232 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: mop.lisp ;;;; Purpose: Metaobject Protocol Interface ;;;; 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$ ;;;; ;;;; This file is Copyright (c) 2000-2006 by Kevin M. Rosenberg ;;;; ************************************************************************* (in-package #:hyperobject) ;; Main class (defclass hyperobject-class (standard-class) ( ;; slots initialized in defclass (user-name :initarg :user-name :type string :initform nil :accessor user-name :documentation "User name for class") (user-name-plural :initarg :user-name-plural :type string :initform nil :accessor user-name-plural :documentation "Plural 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 :accessor version :documentation "Version number for class") (closures :initarg :closures :initform nil :accessor closures :documentation "Closures to call on slot chnages") (sql-name :initarg :sql-name :accessor sql-name :initform nil :documentation "SQL Name for this class") (guid :initarg :guid :accessor guid :initform nil :documentation "ID string for this class") ;;; The remainder of these fields are calculated one time ;;; in finalize-inheritence. (subobjects :initform nil :accessor subobjects :documentation "List of fields that contain a list of subobjects objects.") (compute-cached-values :initform nil :accessor compute-cached-values :documentation "List of fields that contain a list of compute-cached-value objects.") (hyperlinks :type list :initform nil :accessor hyperlinks :documentation "List of fields that have hyperlinks") (direct-rules :type list :initform nil :initarg :direct-rules :accessor direct-rules :documentation "List of rules to fire on slot changes.") (direct-views :type list :initform nil :initarg :direct-views :accessor direct-views :documentation "List of views") (class-id :type integer :initform (+ (* 1000000 (get-universal-time)) (random 1000000)) :accessor class-id :documentation "Unique ID for the class") (default-view :initform nil :initarg :default-view :accessor default-view :documentation "The default view for a class") (documementation :initform nil :initarg :documentation :documentation "Documentation string for hyperclass.") ;; SQL commands (create-table-cmd :initform nil :reader create-table-cmd) (create-indices-cmds :initform nil :reader create-index-cmds) (drop-table-cmd :initform nil :reader drop-table-cmd) (views :type list :initform nil :initarg :views :accessor views :documentation "List of views") (rules :type list :initform nil :initarg :rules :accessor rules :documentation "List of rules") ) (:documentation "Metaclass for Markup Language classes.")) (defclass subobject () ((name-class :type symbol :initarg :name-class :reader name-class) (name-slot :type symbol :initarg :name-slot :reader name-slot) (lazy-class :type symbol :initarg :lazy-class :reader lazy-class) (lookup :type (or function symbol) :initarg :lookup :reader lookup) (lookup-keys :type list :initarg :lookup-keys :reader lookup-keys)) (:documentation "subobject information") (:default-initargs :name-class nil :name-slot nil :lazy-class nil :lookup nil :lookup-keys nil)) (defclass compute-cached-value () ((name-class :type symbol :initarg :name-class :reader name-class) (name-slot :type symbol :initarg :name-slot :reader name-slot) (lazy-class :type symbol :initarg :lazy-class :reader lazy-class) (lookup :type (or function symbol) :initarg :lookup :reader lookup) (lookup-keys :type list :initarg :lookup-keys :reader lookup-keys)) (:documentation "subobject information") (:default-initargs :name-class nil :name-slot nil :lazy-class nil :lookup nil :lookup-keys nil)) (defmethod print-object ((obj subobject) s) (print-unreadable-object (obj s :type t) (format s "~S" (name-slot obj)))) (defclass hyperlink () ((name :type symbol :initform nil :initarg :name :reader name) (lookup ;; The type specifier seems to break sbcl :type (or function symbol) ;; :type t :initform nil :initarg :lookup :reader lookup) (link-parameters :type list :initform nil :initarg :link-parameters :reader link-parameters))) (defmethod print-object ((obj hyperlink) s) (print-unreadable-object (obj s :type t :identity t) (format s "~S" (name obj)))) (defmethod validate-superclass ((class hyperobject-class) (superclass standard-class)) t) (declaim (inline delistify)) (defun delistify (list) "Some MOPs, like openmcl 0.14.2, cons attribute values in a list." (if (listp list) (car list) list)) (defun remove-keyword-arg (arglist akey) (let ((mylist arglist) (newlist ())) (labels ((pop-arg (alist) (let ((arg (pop alist)) (val (pop alist))) (unless (equal arg akey) (setf newlist (append (list arg val) newlist))) (when alist (pop-arg alist))))) (pop-arg mylist)) newlist)) (defun remove-keyword-args (arglist akeys) (let ((mylist arglist) (newlist ())) (labels ((pop-arg (alist) (let ((arg (pop alist)) (val (pop alist))) (unless (find arg akeys) (setf newlist (append (list arg val) newlist))) (when alist (pop-arg alist))))) (pop-arg mylist)) newlist)) (defmethod shared-initialize :around ((class hyperobject-class) slot-names &rest initargs &key direct-superclasses user-name sql-name name description &allow-other-keys) ;(format t "ii ~S ~S ~S ~S ~S~%" initargs base-table direct-superclasses user-name sql-name) (let ((root-class (find-class 'hyperobject nil)) (vmc 'hyperobject-class) user-name-plural user-name-str sql-name-str) ;; when does CLSQL pass :qualifier to initialize instance? (setq user-name-str (if user-name (delistify user-name) (and name (format nil "~:(~A~)" name)))) (setq sql-name-str (if sql-name (delistify sql-name) (and name (lisp-name-to-sql-name name)))) (if sql-name (delistify sql-name) (and name (lisp-name-to-sql-name name))) (setq description (delistify description)) (setq user-name-plural (if (and (consp user-name) (second user-name)) (second user-name) (and user-name-str (format nil "~A~P" user-name-str 2)))) (flet ((do-call-next-method (direct-superclasses) (let ((fn-args (list class slot-names :direct-superclasses direct-superclasses)) (rm-args '(:direct-superclasses))) (when user-name-str (setq fn-args (nconc fn-args (list :user-name user-name-str))) (push :user-name rm-args)) (when user-name-plural (setq fn-args (nconc fn-args (list :user-name-plural user-name-plural))) (push :user-name-plural rm-args)) (when sql-name-str (setq fn-args (nconc fn-args (list :sql-name sql-name-str))) (push :sql-name rm-args)) (when description (setq fn-args (nconc fn-args (list :description description))) (push :description rm-args)) (setq fn-args (nconc fn-args (remove-keyword-args initargs rm-args))) (apply #'call-next-method fn-args)))) (if root-class (if (some #'(lambda (super) (typep super vmc)) direct-superclasses) (do-call-next-method direct-superclasses) (do-call-next-method direct-superclasses #+nil (append (list root-class) direct-superclasses))) (do-call-next-method direct-superclasses))))) (defmethod finalize-inheritance :after ((cl hyperobject-class)) "Initialize a hyperobject class. Calculates all class slots" (finalize-subobjects cl) (finalize-compute-cached cl) (init-hyperobject-class cl)) (eval-when (:compile-toplevel :load-toplevel :execute) (when (>= (length (generic-function-lambda-list (ensure-generic-function 'compute-effective-slot-definition))) 3) (pushnew :ho-normal-cesd cl:*features*)) (when (>= (length (generic-function-lambda-list (ensure-generic-function 'direct-slot-definition-class))) 3) (pushnew :ho-normal-dsdc cl:*features*)) (when (>= (length (generic-function-lambda-list (ensure-generic-function 'effective-slot-definition-class))) 3) (pushnew :ho-normal-esdc cl:*features*))) (defmethod direct-slot-definition-class ((cl hyperobject-class) #+ho-normal-dsdc &rest iargs) (declare (ignore iargs)) (find-class 'hyperobject-dsd)) (defmethod effective-slot-definition-class ((cl hyperobject-class) #+ho-normal-esdc &rest iargs) (declare (ignore iargs)) (find-class 'hyperobject-esd)) ;;; Slot definitions (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro process-class-option (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)) (list name `',value)) #+(or allegro sbcl cmu scl openmcl) (declare (ignore slot-name required)) ) (defmacro process-slot-option (slot-name) #+lispworks `(defmethod clos:process-a-slot-option ((class hyperobject-class) (option (eql ,slot-name)) value already-processed-options slot) (list* option `',value already-processed-options)) #-lispworks (declare (ignore slot-name)) ) (dolist (option *class-options*) (eval `(process-class-option ,option))) (dolist (option *slot-options*) (eval `(process-slot-option ,option))) (eval `(defclass hyperobject-dsd (standard-direct-slot-definition) (,@(mapcar #'(lambda (x) `(,(intern (symbol-name x)) :initform nil)) *slot-options-no-initarg*) ,@(mapcar #'(lambda (x) `(,(intern (symbol-name x)) :initarg ,(intern (symbol-name x) (symbol-name :keyword)) :initform nil :accessor ,(intern (concatenate 'string (symbol-name :dsd-) (symbol-name x))))) *slot-options*)))) (eval `(defclass hyperobject-esd (standard-effective-slot-definition) (,@(mapcar #'(lambda (x) `(,(intern (symbol-name x)) :initarg ,(intern (symbol-name x) (symbol-name :keyword)) :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) (cond ((null obj) nil) ((eq t obj) t) ((atom obj) (intern (symbol-name obj) (find-package 'keyword))) ((consp obj) (cons (intern-in-keyword (car obj) ) (intern-in-keyword (cdr obj)))) (t obj))) (defun canonicalize-value-type (vt) (typecase vt (atom (ensure-keyword vt)) (cons (list (ensure-keyword (car vt)) (cadr vt))) (t t))) (defmethod compute-effective-slot-definition :around ((cl hyperobject-class) #+ho-normal-cesd name dsds) (declare (ignore #+ho-normal-cesd name)) (let ((esd (call-next-method))) (if (typep esd 'hyperobject-esd) (compute-hyperobject-esd esd dsds) esd))) (defun compute-hyperobject-esd (esd dsds) (let* ((dsd (car dsds))) (multiple-value-bind (sql-type sql-length) (value-type-to-sql-type (dsd-value-type dsd)) (setf (esd-sql-type esd) sql-type) (setf (esd-sql-length esd) sql-length)) (setf (esd-user-name esd) (aif (dsd-user-name dsd) it (string-downcase (symbol-name (slot-definition-name dsd))))) (setf (esd-sql-name esd) (aif (dsd-sql-name dsd) it (lisp-name-to-sql-name (slot-definition-name dsd)))) (setf (esd-sql-name esd) (aif (dsd-sql-name dsd) it (lisp-name-to-sql-name (slot-definition-name dsd)))) (dolist (name '(value-type print-formatter subobject hyperlink hyperlink-parameters unbound-lookup description value-constraint indexed null-allowed unique short-description void-text read-only-groups hidden-groups unit disable-predicate view-type list-of-values compute-cached-value stored)) (setf (slot-value esd name) (slot-value dsd name))) esd)) (defun lisp-name-to-sql-name (lisp) "Convert a lisp name (atom or list, string or symbol) into a canonical SQL name" (unless (stringp lisp) (setq lisp (typecase lisp (symbol (symbol-name lisp)) (t (write-to-string lisp))))) (do* ((len (length lisp)) (sql (make-string len)) (i 0 (1+ i))) ((= i len) (string-upcase sql)) (declare (fixnum i) (simple-string sql)) (setf (schar sql i) (let ((c (char lisp i))) (case c ((#\- #\$ #\+ #\#) #\_) (otherwise c)))))) #+ho-normal-cesd (setq cl:*features* (delete :ho-normal-cesd cl:*features*)) #+ho-normal-dsdc (setq cl:*features* (delete :ho-normal-dsdc cl:*features*)) #+ho-normal-esdc (setq cl:*features* (delete :ho-normal-esdc cl:*features*)) (defun lisp-type-is-a-string (type) (or (eq type 'string) (and (listp type) (some #'(lambda (x) (eq x 'string)) type)))) (defun base-value-type (value-type) (if (atom value-type) value-type (car value-type))) (defun value-type-to-lisp-type (value-type) (case (base-value-type value-type) ((:string :cdata :varchar :char) '(or null string)) (:datetime '(or null integer)) (:character '(or null character)) (:fixnum '(or null fixnum)) (:boolean '(or null boolean)) ((:integer :long-integer) '(or null integer)) ((:float :single-float) '(or null single-float)) (:double-float '(or null double-float)) (otherwise t))) (defun value-type-to-sql-type (value-type) "Return two values, the sql type and field length." (let ((type (base-value-type value-type)) (length (when (consp value-type) (cadr value-type)))) (values (case type ((:char :character) :char) (:varchar :varchar) ((:fixnum :integer) :integer) (:long-integer :long-integer) (:boolean :boolean) ((:float :single-float) :single-float) (:double-float :double-float) (:datetime :long-integer) (otherwise :text)) length))) ;;;; Class initialization function ;; One entry for each class with lazy readers defined. The value is a plist mapping ;; slot-name to a lazy reader, each of which is a list of a function and slot-names. (defvar *lazy-readers* (make-hash-table)) (defmethod slot-unbound ((class hyperobject-class) instance slot-name) (let ((lazy-reader (loop for super in (class-precedence-list class) as lazy-reader = (getf (gethash super *lazy-readers*) slot-name) when lazy-reader return it))) (if lazy-reader (setf (slot-value instance slot-name) (if (atom lazy-reader) (make-instance lazy-reader) (apply (car lazy-reader) (loop for arg-slot-name in (cdr lazy-reader) collect (slot-value instance arg-slot-name))))) ;; No lazy reader -- defer to regular slot-unbound handling. (call-next-method)))) ;; The reader is a function and the reader-keys are slot names. The slot is lazily set to ;; the result of applying the function to the slot-values of those slots, and that value ;; is also returned. (defun ensure-lazy-reader (cl class-name slot-name lazy-class reader &rest reader-keys) (declare (ignore class-name)) (setf (getf (gethash cl *lazy-readers*) slot-name) (aif lazy-class it (list* reader (copy-list reader-keys))))) (defun remove-lazy-reader (class-name slot-name) (setf (getf (gethash (find-class class-name) *lazy-readers*) slot-name) nil)) (defun store-lazily-computed-objects (cl slot esd-accessor obj-class) (setf (slot-value cl slot) (let ((objs '())) (dolist (slot (class-slots cl)) (let-when (def (funcall esd-accessor slot)) (let ((obj (make-instance obj-class :name-class (class-name cl) :name-slot (slot-definition-name slot) :lazy-class (when (atom def) def) :lookup (when (listp def) (car def)) :lookup-keys (when (listp def) (cdr def))))) (unless (eq (lookup obj) t) (apply #'ensure-lazy-reader cl (name-class obj) (name-slot obj) (lazy-class obj) (lookup obj) (lookup-keys obj)) (push obj objs))))) ;; sbcl/cmu reverse class-slots compared to the defclass form ;; so re-reverse on cmu/sbcl #+(or cmu sbcl) objs #-(or cmu sbcl) (nreverse objs) ))) (defun finalize-subobjects (cl) (store-lazily-computed-objects cl 'subobjects 'esd-subobject 'subobject)) (defun finalize-compute-cached (cl) (store-lazily-computed-objects cl 'compute-cached-values 'esd-compute-cached-value 'compute-cached-value)) (defun finalize-documentation (cl) "Calculate class documentation slot" (let ((*print-circle* nil)) (setf (documentation cl 'type) (format nil "Hyperobject~A~A~A~A" (aif (user-name cl) (format nil ": ~A" it "")) (aif (description cl) (format nil "~%Class description: ~A" it) "") (aif (subobjects cl) (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name-slot it)) "") (aif (default-print-slots cl) (format nil "~%Default print slots:~{ ~A~}" it) "") )))) (defun finalize-hyperlinks (cl) (let ((hyperlinks '())) (dolist (esd (class-slots cl)) (awhen (slot-value esd 'hyperlink) (push (make-instance 'hyperlink :name (slot-definition-name esd) :lookup it :link-parameters (slot-value esd 'hyperlink-parameters)) hyperlinks))) ;; cmu/sbcl reverse class-slots compared to the defclass form ;; hyperlinks is already reversed from the dolist/push loop, so re-reverse on sbcl/cmu #-(or cmu sbcl) (setq hyperlinks (nreverse hyperlinks)) (setf (slot-value cl 'hyperlinks) hyperlinks))) (defun init-hyperobject-class (cl) "Initialize a hyperobject class. Calculates all class slots" (finalize-views cl) (finalize-hyperlinks cl) (finalize-sql cl) (finalize-rules cl) (finalize-documentation cl)) ;;;; ************************************************************************* ;;;; Metaclass Slot Accessors ;;;; ************************************************************************* (defun find-slot-by-name (cl name) (find name (class-slots cl) :key #'slot-definition-name)) (defun hyperobject-class-user-name (obj) (user-name (class-of obj))) (defun hyperobject-class-user-name-plural (obj) (user-name-plural (class-of obj))) (defun hyperobject-class-subobjects (obj) (subobjects (class-of obj))) (defun hyperobject-class-hyperlinks (obj) (hyperlinks (class-of obj))) (defun hyperobject-class-slots (obj) ;; cmucl/sbcl reverse class-slots #+(or cmu sbcl) (reverse (class-slots (class-of obj))) #-(or cmu sbcl) (class-slots (class-of obj))) (defun all-subobjects (obj) "Returns a list of all subobjects in an object" (let ((so-list '())) (dolist (subobj-obj (subobjects (class-of obj)) (nreverse so-list)) (dolist (so (funcall (name-slot subobj-obj) obj)) (push so so-list)))))