;;-*- Mode: Lisp; Package: XML -*-
;*********************************************************************
;* *
;* X M L i s p *
;* *
;*********************************************************************
;* Author : Alexander Repenning, alexander@agentsheets.com *
;* http://www.agentsheets.com *
;* Copyright : (c) 1996-2008, AgentSheets Inc. *
;* Filename : XMLisp.lisp *
;* Last Update : 12/16/08 *
;* Version : *
;* 1.0 : 09/19/04 *
;* 1.1 : 09/30/04 encode/decode strings in XML *
;* 1.1.1 : 10/01/04 subobjects can be aggregated as arrays *
;* 1.2 : 10/09/04 abreviated printing to inspector/listener *
;* serialization includes arrays *
;* headers *
;* :type slot interpretation *
;* 1.3 : 10/11/04 content only tags, e.g., bla *
;* 1.4 : 10/12/04 SGML tags: <--, *
;* 2.3.1 : 07/11/05 deal with double AND single quote values *
;* 2.3.2 : 07/14/05 concatenate all content *
;* 2.3.3 : 07/15/05 *Warn-if-undefined-XML-Decoder-Type, *
;* 2.3.4 : 07/20/05 export xml-tag-name-symbol *
;* 2.3.5 : 08/01/05 show-error-in-stream-to-user in *
;* set-attribute-value *
;* encode single quote ' *
;* 2.3.6 : 08/16/05 slot-definition-type most-specific-class *
;* 2.3.7 : 08/30/05 export decode-xml-string encode-xml-string*
;* 2.3.8 : 09/14/05 check boundp *Xml-Stream* *
;* 2.3.9 : 09/16/05 list type decoder *
;* 2.4 : 10/17/05 print-default-value-attributes-p *
;* 2.4.1 : 11/02/05 read-return-value *
;* 2.4.2 : 11/04/05 double-float CODEC *
;* 2.4.3 : 11/09/05 short-float CODE don't print "d" *
;* 2.4.4 : 11/10/05 do not print lisp escape chars in strings *
;* 2.4.5 : 12/02/05 AI: convert relative unix path to lisppath*
;* 2.5 : 01/18/06 print non-t slot types attributes *
;* 2.5.1 : 01/23/06 attribute-name->slot-name, *
;* slot-name->attribute-name *
;* 2.5.2 : 02/10/06 do not print ..D0 double floats *
;* 2.5.3 : 02/17/06 file (setf file). Set by load-object *
;* 2.5.4 : 02/23/06 print pathname to stream *
;* 2.5.5 : 04/05/06 without-xml-reader macro *
;* 2.5.6 : 06/20/06 print-slot-name-value-type-as-attribute *
;* 2.6 : 08/25/06 path type and CODECs *
;* 2.7 : 01/17/07 float array CODEC *
;* 3.0 : 02/10/07 Optimized tree shacked: single file *
;* 3.0.1 : 08/14/07 do not print array content into listener *
;* 3.0.2 : 09/26/07 AI: fallback-class-name-for-element-name *
;* 3.0.3 : 10/30/07 parse-file-name fixed Eirik Mikkelsen *
;* 3.0.4 : 01/29/08 AI: single-float codec *
;* 3.0.5 : 09/23/08 reader skip "<)" *
;* 3.1 : 10/09/08 enhanced reader to deal with *
;* not including space after element name *
;* 3.2 : 11/14/08 if slot if missing lookup acccessor *
;* 3.2.1 : 11/28/08 handle type specifier lists, e.g., boolean*
;* 3.5 : 12/03/08 early instantiation model (see below) *
;* 3.5.1 : 12/10/08 string-upcase symbol codec, float codec *
;* 3.5.2 : 12/16/08 read-return-value fixed, keyword CODEC *
;* Systems : G4, OS X 10.5.5 *
;* Lisps : MCL 5.0, MCL 5.2, LispWorks 4.3.7, CCL 1.2 *
;* CLISP 2.33.83, CMUCL, AGL *
;* Licence : LGPL *
;* Based on : XML by Andri Ioannidou *
;* Abstract : Integrate XML reading/writing with Lisp *
;* To use XMLisp mix in xml-serializer class into your class. *
;* When lisp reader sees: it will *
;* - create an instance of class "BLA" *
;* - set slot "X" to 13 and slot "Y" to 20 *
;* - if slot includes :type use CODEC *
;* Objects can have subobjects. Aggregation can be controlled *
;* by redefining aggregator functions, e.g., add-subobject *
;* *
;* Initialization: *
;* this kind of element: *
;* *
;* *
;* *
;* *
;* - reading "attribute-name
;; reading
load-object save-object finished-reading finished-reading-attributes read-typed-attribute-value
read-return-value without-xml-reader
attribute-name->slot-name
;; do not export "File"
;; file
;; variables
def-element-class-name xml-tag-name-string
;; MOP
class-slots find-slot-definition
;; MOP goodies
most-specific-class
;; names
xml-tag-name-symbol
;; variables
*xmlisp-packages*
*fallback-class-name-for-element-name-hook*
;; types
path string-or-null integer-or-null
))
(defvar *XMLiSP-Element-Class-Names* (make-hash-table :test #'eq) "table mapping element names to class names")
(defvar *XMLisp-Print-Verbose* nil "Variable for printing debugging messages. If true, then the messages are printed. If nil, then the messages are not printed.")
(defparameter *Fallback-Class-Name-For-Element-Name-Hook* nil "Function to call to get element name if there is no class to match")
;*******************************
; Printing Utils *
;*******************************
(defun FORMAT-IF-VERBOSE (Destination Control-String &rest Arguments)
(when *XMLisp-Print-Verbose*
(terpri)
(apply #'format Destination Control-String Arguments)))
;***********************************
; low level: Character Predicates *
; elaborate thanks to unicode *
;***********************************
(defun WHITE-SPACE-P (Char)
(declare (optimize (speed 3) (safety 0)))
(case (char-code Char)
(#x20 t)
(#x9 t)
(#xD t)
(#xA t)
(t nil)))
(defun DIGITP (Char)
(declare (optimize (speed 3) (safety 0)))
(let ((Code (char-code Char)))
(or (and (>= Code #x0030) (<= Code #x0039))
(and (>= Code #x0660) (<= Code #x0669))
(and (>= Code #x06F0) (<= Code #x06F9))
(and (>= Code #x0966) (<= Code #x096F))
(and (>= Code #x09E6) (<= Code #x09EF))
(and (>= Code #x0A66) (<= Code #x0A6F))
(and (>= Code #x0AE6) (<= Code #x0AEF))
(and (>= Code #x0B66) (<= Code #x0B6F))
(and (>= Code #x0BE7) (<= Code #x0BEF))
(and (>= Code #x0C66) (<= Code #x0C6F))
(and (>= Code #x0CE6) (<= Code #x0CEF))
(and (>= Code #x0D66) (<= Code #x0D6F))
(and (>= Code #x0E50) (<= Code #x0E59))
(and (>= Code #x0ED0) (<= Code #x0ED9))
(and (>= Code #x0F20) (<= Code #x0F29)))))
(defun COMBINING-CHAR-P (Char)
(declare (optimize (speed 3) (safety 0)))
(let ((Code (char-code Char)))
(or (and (>= Code #x0300) (<= Code #x0345))
(and (>= Code #x0360) (<= Code #x0361))
(and (>= Code #x0483) (<= Code #x0486))
(and (>= Code #x0591) (<= Code #x05A1))
(and (>= Code #x05A3) (<= Code #x05B9))
(and (>= Code #x05BB) (<= Code #x05BD))
(= Code #x05BF)
(and (>= Code #x05C1) (<= Code #x05C2))
(= Code #x05C4)
(and (>= Code #x064B) (<= Code #x0652))
(= Code #x0670)
(and (>= Code #x06D6) (<= Code #x06DC))
(and (>= Code #x06DD) (<= Code #x06DF))
(and (>= Code #x06E0) (<= Code #x06E4))
(and (>= Code #x06E7) (<= Code #x06E8))
(and (>= Code #x06EA) (<= Code #x06ED))
(and (>= Code #x0901) (<= Code #x0903))
(= Code #x093C)
(and (>= Code #x093E) (<= Code #x094C))
(= Code #x094D)
(and (>= Code #x0951) (<= Code #x0954))
(and (>= Code #x0962) (<= Code #x0963))
(and (>= Code #x0981) (<= Code #x0983))
(= Code #x09BC)
(= Code #x09BE)
(= Code #x09BF)
(and (>= Code #x09C0) (<= Code #x09C4))
(and (>= Code #x09C7) (<= Code #x09C8))
(and (>= Code #x09CB) (<= Code #x09CD))
(= Code #x09D7)
(and (>= Code #x09E2) (<= Code #x09E3))
(= Code #x0A02)
(= Code #x0A3C)
(= Code #x0A3E)
(= Code #x0A3F)
(and (>= Code #x0A40) (<= Code #x0A42))
(and (>= Code #x0A47) (<= Code #x0A48))
(and (>= Code #x0A4B) (<= Code #x0A4D))
(and (>= Code #x0A70) (<= Code #x0A71))
(and (>= Code #x0A81) (<= Code #x0A83))
(= Code #x0ABC)
(and (>= Code #x0ABE) (<= Code #x0AC5))
(and (>= Code #x0AC7) (<= Code #x0AC9))
(and (>= Code #x0ACB) (<= Code #x0ACD))
(and (>= Code #x0B01) (<= Code #x0B03))
(= Code #x0B3C)
(and (>= Code #x0B3E) (<= Code #x0B43))
(and (>= Code #x0B47) (<= Code #x0B48))
(and (>= Code #x0B4B) (<= Code #x0B4D))
(and (>= Code #x0B56) (<= Code #x0B57))
(and (>= Code #x0B82) (<= Code #x0B83))
(and (>= Code #x0BBE) (<= Code #x0BC2))
(and (>= Code #x0BC6) (<= Code #x0BC8))
(and (>= Code #x0BCA) (<= Code #x0BCD))
(= Code #x0BD7)
(and (>= Code #x0C01) (<= Code #x0C03))
(and (>= Code #x0C3E) (<= Code #x0C44))
(and (>= Code #x0C46) (<= Code #x0C48))
(and (>= Code #x0C4A) (<= Code #x0C4D))
(and (>= Code #x0C55) (<= Code #x0C56))
(and (>= Code #x0C82) (<= Code #x0C83))
(and (>= Code #x0CBE) (<= Code #x0CC4))
(and (>= Code #x0CC6) (<= Code #x0CC8))
(and (>= Code #x0CCA) (<= Code #x0CCD))
(and (>= Code #x0CD5) (<= Code #x0CD6))
(and (>= Code #x0D02) (<= Code #x0D03))
(and (>= Code #x0D3E) (<= Code #x0D43))
(and (>= Code #x0D46) (<= Code #x0D48))
(and (>= Code #x0D4A) (<= Code #x0D4D))
(= Code #x0D57)
(= Code #x0E31)
(and (>= Code #x0E34) (<= Code #x0E3A))
(and (>= Code #x0E47) (<= Code #x0E4E))
(= Code #x0EB1)
(and (>= Code #x0EB4) (<= Code #x0EB9))
(and (>= Code #x0EBB) (<= Code #x0EBC))
(and (>= Code #x0EC8) (<= Code #x0ECD))
(and (>= Code #x0F18) (<= Code #x0F19))
(= Code #x0F35)
(= Code #x0F37)
(= Code #x0F39)
(= Code #x0F3E)
(= Code #x0F3F)
(and (>= Code #x0F71) (<= Code #x0F84))
(and (>= Code #x0F86) (<= Code #x0F8B))
(and (>= Code #x0F90) (<= Code #x0F95))
(= Code #x0F97)
(and (>= Code #x0F99) (<= Code #x0FAD))
(and (>= Code #x0FB1) (<= Code #x0FB7))
(= Code #x0FB9)
(and (>= Code #x20D0) (<= Code #x20DC))
(= Code #x20E1)
(and (>= Code #x302A) (<= Code #x302F))
(= Code #x3099)
(= Code #x309A))))
(defun BASE-CHAR-P (Char)
(declare (optimize (speed 3) (safety 0)))
(let ((Code (char-code Char)))
(or (and (>= Code #x0041) (<= Code #x005A))
(and (>= Code #x0061) (<= Code #x007A))
(and (>= Code #x00C0) (<= Code #x00D6))
(and (>= Code #x00D8) (<= Code #x00F6))
(and (>= Code #x00F8) (<= Code #x00FF))
(and (>= Code #x0100) (<= Code #x0131))
(and (>= Code #x0134) (<= Code #x013E))
(and (>= Code #x0141) (<= Code #x0148))
(and (>= Code #x014A) (<= Code #x017E))
(and (>= Code #x0180) (<= Code #x01C3))
(and (>= Code #x01CD) (<= Code #x01F0))
(and (>= Code #x01F4) (<= Code #x01F5))
(and (>= Code #x01FA) (<= Code #x0217))
(and (>= Code #x0250) (<= Code #x02A8))
(and (>= Code #x02BB) (<= Code #x02C1))
(= Code #x0386)
(and (>= Code #x0388) (<= Code #x038A))
(= Code #x038C)
(and (>= Code #x038E) (<= Code #x03A1))
(and (>= Code #x03A3) (<= Code #x03CE))
(and (>= Code #x03D0) (<= Code #x03D6))
(= Code #x03DA)
(= Code #x03DC)
(= Code #x03DE)
(= Code #x03E0)
(and (>= Code #x03E2) (<= Code #x03F3))
(and (>= Code #x0401) (<= Code #x040C))
(and (>= Code #x040E) (<= Code #x044F))
(and (>= Code #x0451) (<= Code #x045C))
(and (>= Code #x045E) (<= Code #x0481))
(and (>= Code #x0490) (<= Code #x04C4))
(and (>= Code #x04C7) (<= Code #x04C8))
(and (>= Code #x04CB) (<= Code #x04CC))
(and (>= Code #x04D0) (<= Code #x04EB))
(and (>= Code #x04EE) (<= Code #x04F5))
(and (>= Code #x04F8) (<= Code #x04F9))
(and (>= Code #x0531) (<= Code #x0556))
(= Code #x0559)
(and (>= Code #x0561) (<= Code #x0586))
(and (>= Code #x05D0) (<= Code #x05EA))
(and (>= Code #x05F0) (<= Code #x05F2))
(and (>= Code #x0621) (<= Code #x063A))
(and (>= Code #x0641) (<= Code #x064A))
(and (>= Code #x0671) (<= Code #x06B7))
(and (>= Code #x06BA) (<= Code #x06BE))
(and (>= Code #x06C0) (<= Code #x06CE))
(and (>= Code #x06D0) (<= Code #x06D3))
(= Code #x06D5)
(and (>= Code #x06E5) (<= Code #x06E6))
(and (>= Code #x0905) (<= Code #x0939))
(= Code #x093D)
(and (>= Code #x0958) (<= Code #x0961))
(and (>= Code #x0985) (<= Code #x098C))
(and (>= Code #x098F) (<= Code #x0990))
(and (>= Code #x0993) (<= Code #x09A8))
(and (>= Code #x09AA) (<= Code #x09B0))
(= Code #x09B2)
(and (>= Code #x09B6) (<= Code #x09B9))
(and (>= Code #x09DC) (<= Code #x09DD))
(and (>= Code #x09DF) (<= Code #x09E1))
(and (>= Code #x09F0) (<= Code #x09F1))
(and (>= Code #x0A05) (<= Code #x0A0A))
(and (>= Code #x0A0F) (<= Code #x0A10))
(and (>= Code #x0A13) (<= Code #x0A28))
(and (>= Code #x0A2A) (<= Code #x0A30))
(and (>= Code #x0A32) (<= Code #x0A33))
(and (>= Code #x0A35) (<= Code #x0A36))
(and (>= Code #x0A38) (<= Code #x0A39))
(and (>= Code #x0A59) (<= Code #x0A5C))
(= Code #x0A5E)
(and (>= Code #x0A72) (<= Code #x0A74))
(and (>= Code #x0A85) (<= Code #x0A8B))
(= Code #x0A8D)
(and (>= Code #x0A8F) (<= Code #x0A91))
(and (>= Code #x0A93) (<= Code #x0AA8))
(and (>= Code #x0AAA) (<= Code #x0AB0))
(and (>= Code #x0AB2) (<= Code #x0AB3))
(and (>= Code #x0AB5) (<= Code #x0AB9))
(= Code #x0ABD)
(= Code #x0AE0)
(and (>= Code #x0B05) (<= Code #x0B0C))
(and (>= Code #x0B0F) (<= Code #x0B10))
(and (>= Code #x0B13) (<= Code #x0B28))
(and (>= Code #x0B2A) (<= Code #x0B30))
(and (>= Code #x0B32) (<= Code #x0B33))
(and (>= Code #x0B36) (<= Code #x0B39))
(= Code #x0B3D)
(and (>= Code #x0B5C) (<= Code #x0B5D))
(and (>= Code #x0B5F) (<= Code #x0B61))
(and (>= Code #x0B85) (<= Code #x0B8A))
(and (>= Code #x0B8E) (<= Code #x0B90))
(and (>= Code #x0B92) (<= Code #x0B95))
(and (>= Code #x0B99) (<= Code #x0B9A))
(= Code #x0B9C)
(and (>= Code #x0B9E) (<= Code #x0B9F))
(and (>= Code #x0BA3) (<= Code #x0BA4))
(and (>= Code #x0BA8) (<= Code #x0BAA))
(and (>= Code #x0BAE) (<= Code #x0BB5))
(and (>= Code #x0BB7) (<= Code #x0BB9))
(and (>= Code #x0C05) (<= Code #x0C0C))
(and (>= Code #x0C0E) (<= Code #x0C10))
(and (>= Code #x0C12) (<= Code #x0C28))
(and (>= Code #x0C2A) (<= Code #x0C33))
(and (>= Code #x0C35) (<= Code #x0C39))
(and (>= Code #x0C60) (<= Code #x0C61))
(and (>= Code #x0C85) (<= Code #x0C8C))
(and (>= Code #x0C8E) (<= Code #x0C90))
(and (>= Code #x0C92) (<= Code #x0CA8))
(and (>= Code #x0CAA) (<= Code #x0CB3))
(and (>= Code #x0CB5) (<= Code #x0CB9))
(= Code #x0CDE)
(and (>= Code #x0CE0) (<= Code #x0CE1))
(and (>= Code #x0D05) (<= Code #x0D0C))
(and (>= Code #x0D0E) (<= Code #x0D10))
(and (>= Code #x0D12) (<= Code #x0D28))
(and (>= Code #x0D2A) (<= Code #x0D39))
(and (>= Code #x0D60) (<= Code #x0D61))
(and (>= Code #x0E01) (<= Code #x0E2E))
(= Code #x0E30)
(and (>= Code #x0E32) (<= Code #x0E33))
(and (>= Code #x0E40) (<= Code #x0E45))
(and (>= Code #x0E81) (<= Code #x0E82))
(= Code #x0E84)
(and (>= Code #x0E87) (<= Code #x0E88))
(= Code #x0E8A)
(= Code #x0E8D)
(and (>= Code #x0E94) (<= Code #x0E97))
(and (>= Code #x0E99) (<= Code #x0E9F))
(and (>= Code #x0EA1) (<= Code #x0EA3))
(= Code #x0EA5)
(= Code #x0EA7)
(and (>= Code #x0EAA) (<= Code #x0EAB))
(and (>= Code #x0EAD) (<= Code #x0EAE))
(= Code #x0EB0)
(and (>= Code #x0EB2) (<= Code #x0EB3))
(= Code #x0EBD)
(and (>= Code #x0EC0) (<= Code #x0EC4))
(and (>= Code #x0F40) (<= Code #x0F47))
(and (>= Code #x0F49) (<= Code #x0F69))
(and (>= Code #x10A0) (<= Code #x10C5))
(and (>= Code #x10D0) (<= Code #x10F6))
(= Code #x1100)
(and (>= Code #x1102) (<= Code #x1103))
(and (>= Code #x1105) (<= Code #x1107))
(= Code #x1109)
(and (>= Code #x110B) (<= Code #x110C))
(and (>= Code #x110E) (<= Code #x1112))
(= Code #x113C)
(= Code #x113E)
(= Code #x1140)
(= Code #x114C)
(= Code #x114E)
(= Code #x1150)
(and (>= Code #x1154) (<= Code #x1155))
(= Code #x1159)
(and (>= Code #x115F) (<= Code #x1161))
(= Code #x1163)
(= Code #x1165)
(= Code #x1167)
(= Code #x1169)
(and (>= Code #x116D) (<= Code #x116E))
(and (>= Code #x1172) (<= Code #x1173))
(= Code #x1175)
(= Code #x119E)
(= Code #x11A8)
(= Code #x11AB)
(and (>= Code #x11AE) (<= Code #x11AF))
(and (>= Code #x11B7) (<= Code #x11B8))
(= Code #x11BA)
(and (>= Code #x11BC) (<= Code #x11C2))
(= Code #x11EB)
(= Code #x11F0)
(= Code #x11F9)
(and (>= Code #x1E00) (<= Code #x1E9B))
(and (>= Code #x1EA0) (<= Code #x1EF9))
(and (>= Code #x1F00) (<= Code #x1F15))
(and (>= Code #x1F18) (<= Code #x1F1D))
(and (>= Code #x1F20) (<= Code #x1F45))
(and (>= Code #x1F48) (<= Code #x1F4D))
(and (>= Code #x1F50) (<= Code #x1F57))
(= Code #x1F59)
(= Code #x1F5B)
(= Code #x1F5D)
(and (>= Code #x1F5F) (<= Code #x1F7D))
(and (>= Code #x1F80) (<= Code #x1FB4))
(and (>= Code #x1FB6) (<= Code #x1FBC))
(= Code #x1FBE)
(and (>= Code #x1FC2) (<= Code #x1FC4))
(and (>= Code #x1FC6) (<= Code #x1FCC))
(and (>= Code #x1FD0) (<= Code #x1FD3))
(and (>= Code #x1FD6) (<= Code #x1FDB))
(and (>= Code #x1FE0) (<= Code #x1FEC))
(and (>= Code #x1FF2) (<= Code #x1FF4))
(and (>= Code #x1FF6) (<= Code #x1FFC))
(= Code #x2126)
(and (>= Code #x212A) (<= Code #x212B))
(= Code #x212E)
(and (>= Code #x2180) (<= Code #x2182))
(and (>= Code #x3041) (<= Code #x3094))
(and (>= Code #x30A1) (<= Code #x30FA))
(and (>= Code #x3105) (<= Code #x312C))
(and (>= Code #xAC00) (<= Code #xD7A3)))))
(defun EXTENDERP (Char)
(declare (optimize (speed 3) (safety 0)))
(let ((Code (char-code Char)))
(or (= Code #x00B7)
(= Code #x02D0)
(= Code #x02D1)
(= Code #x0387)
(= Code #x0640)
(= Code #x0E46)
(= Code #x0EC6)
(= Code #x3005)
(and (>= Code #x3031) (<= Code #x3035))
(and (>= Code #x309D) (<= Code #x309E))
(and (>= Code #x30FC) (<= Code #x30FE)))))
(defun IDEOGRAPHICP (Char)
(declare (optimize (speed 3) (safety 0)))
(let ((Code (char-code Char)))
(or (= Code #x3007)
(and (>= Code #x4E00) (<= Code #x9FA5))
(and (>= Code #x3021) (<= Code #x3029)))))
(defun LETTERP (Char)
(declare (optimize (speed 3) (safety 0)))
(or (base-char-p Char)
(ideographicp Char)))
(defun NAMECHARP (Char)
(declare (optimize (speed 3) (safety 0)))
(or (letterp Char)
(digitp Char)
(char= Char #\.)
(char= Char #\-)
(char= Char #\_)
(char= Char #\:)
(combining-char-p Char)
(extenderp Char)))
;*******************************
; XML Serializer class *
;*******************************
(defclass XML-SERIALIZER ()
((content :accessor content :initarg :content :initform nil :documentation "content not wrapped up as tag or attribute, e.g. the link name of tag"))
(:documentation "Mixin to serialize objects as XML looking things"))
(defgeneric SAVE-OBJECT (Xml-Serializer Filename &key Verbose If-Exists Xml-Header)
(:documentation "Save object into . By default add a valid XML header"))
(defgeneric SET-ATTRIBUTE-VALUE (Xml-Serializer Attribute-Name Value)
(:documentation "Set the value of an attribute. Default: find slot matching and set its value to "))
(defgeneric ADD-SUBOBJECT (Xml-Serializer Subobject)
(:documentation "Add a subobject. Default: If subobject is of type bla and there is a slot called bla assign it to that slot. If subobject is of type bla and there is a slot called blas then add bla as element of a list to slot blas."))
(defgeneric (SETF PART-OF) (Container Xml-Serializer)
(:documentation "Called after I got added as subobject to container. Add a \"part-of\" to capture this link if needed"))
(defgeneric PART-OF (Xml-Serializer)
(:documentation "The object containing me."))
(defgeneric FILE (Xml-Serializer)
(:documentation "the file containing the object"))
(defgeneric (SETF FILE) (File Xml-Serializer)
(:documentation "called when load-object read in the object from a file"))
(defgeneric ADD-OBJECT-TO-SLOT (Xml-Serializer Object Slot-Name)
(:documentation "Add object to slot . Default: nconc object to end of list, not good for large lists but preserves reading order."))
(defgeneric FIND-SLOT-DEFINITION (Xml-Serializer Name)
(:documentation "Return slot defnition matching "))
(defgeneric CLEANUP-SUB-OBJECT-SLOTS (Xml-Serializer Slot-Names)
(:documentation "Called after all the sub objects have been added"))
(defgeneric XML-PRINTABLE-AS-SUBELEMENT-P (Xml-Serializer)
(:documentation "True if printable as subelement "))
(defgeneric XML-PRINTABLE-AS-ATTRIBUTE-VALUE-P (Xml-Serializer)
(:documentation "True if printable as attribute value bla=\"???\""))
(defgeneric PRINT-TYPED-ATTRIBUTE-VALUE (Value Type Stream)
(:documentation "Encode attribute into an external XML compliant represetation and print into "))
(defgeneric READ-TYPED-ATTRIBUTE-VALUE (Value Type)
(:documentation "Return decoded XML of . "))
(defgeneric PRINT-TYPED-SUBELEMENT-VALUE (Value Type Stream)
(:documentation "Encode attribute into an external XML compliant represetation and print into "))
(defgeneric MAP-OBJECT (Collection Function)
(:documentation "If is a structured object such as a string, list or array call with each element"))
(defgeneric PRINT-SLOTS (Xml-Serializer)
(:documentation "List of slot names to be printed. Return nil to print no slots, :all to print all. Slots will still be excluded when print-slot-with-name-p returns nil"))
(defgeneric PRINT-SLOT-WITH-NAME-P (Xml-Serializer Name)
(:documentation "Return true if slot with should be printed. Default: t. Typical use: avoid recursion"))
(defgeneric PRINT-SUBELEMENTS-TO-STREAM-P (Xml-Serializer Stream)
(:documentation "If true then sub elements, if there are any, will be printed into stream"))
(defgeneric PRINT-SLOT-NAME-VALUE-TYPE-AS-ATTRIBUTE (Xml-Serializer Name Value Type Stream)
(:documentation "Print ''='' into . can be used for encoding"))
(defgeneric PRINT-SLOT-VALUE-AS-ATTRIBUTE (Xml-Serializer Slot Value)
(:documentation "Print as attribute of "))
(defgeneric PRINT-DEFAULT-VALUE-ATTRIBUTES-P (Xml-Serializer)
(:documentation "If true print attributes that have same value as :initform. Good idea for large sets with highly redundant information. Bad idea if value if :initform changes later"))
(defgeneric FINISHED-READING (Xml-Serializer Stream)
(:documentation "called when done with reading: all attributes and sub elements have been created"))
(defgeneric FINISHED-READING-ATTRIBUTES (Xml-Serializer Stream)
(:documentation "called when done with reading attributes: sub elements have NOT been created"))
(defgeneric READ-RETURN-VALUE (Xml-Serializer)
(:documentation "The value returned from reading an xml element. Usually the element itself. This method is called after reading is completely finished."))
(defgeneric XML-TAG-NAME-STRING (Xml-Serializer)
(:documentation "return the tag name of element. Default to name only - no package prefix."))
;____________________________
; Attribute & Slot Names |
;____________________________
(defgeneric ATTRIBUTE-NAME->SLOT-NAME (Xml-Serializer Attribute-Name)
(:documentation "an attribute name will be mapped to this slot name. Default to identity"))
(defgeneric SLOT-NAME->ATTRIBUTE-NAME (Xml-Serializer Slot-Name)
(:documentation "a slot name will be mapped to this attribute name. Default to identity"))
;____________________________
; Element & Class Names |
;____________________________
(defmacro DEF-ELEMENT-CLASS-NAME (Element-Name Class-Name)
`(setf (gethash ',Element-Name *XMLISP-Element-Class-Names*) ',Class-Name))
(defun ELEMENT-CLASS-NAME (Element-Name) "
in: Element-Name symbol.
out: Class-Name symbol.
Return the class name."
(gethash Element-Name *XMLISP-Element-Class-Names*))
(defun CLASS-ELEMENT-NAME (Class-Name) "
in: Class-Name symbol.
out: Element-Name symbol.
Return the element-name matching ."
(maphash
#'(lambda (Key Value)
(when (eq Class-Name Value) (return-from class-element-name Key)))
*XMLISP-Element-Class-Names*))
;____________________________
; default implementations |
;____________________________
;; names and print names
(defmethod XML-TAG-NAME-SYMBOL ((Self xml-serializer))
(or (class-element-name (type-of Self))
(type-of Self)))
(defmethod XML-TAG-NAME-STRING ((Self xml-serializer))
(string-downcase (symbol-name (xml-tag-name-symbol Self))))
;; map objects into their components
(defmethod MAP-OBJECT ((Self xml-serializer) Function)
(funcall Function Self))
(defmethod MAP-OBJECT ((Self sequence) Function)
(map nil Function Self))
(defmethod MAP-OBJECT ((Self hash-table) Function)
(maphash #'(lambda (Key Value) (declare (ignore Key)) (funcall Function Value)) Self))
(defmethod MAP-OBJECT ((Self number) Function)
(funcall Function Self))
(defmethod MAP-OBJECT ((Self string) Function)
(funcall Function Self))
(defmethod MAP-OBJECT ((Self symbol) Function)
(funcall Function Self))
(defmethod MAP-OBJECT ((Self array) Function)
(let* ((Size (array-total-size Self))
(Vector (make-array Size :element-type (array-element-type Self) :displaced-to Self)))
(dotimes (I Size)
(let ((Element (aref Vector I)))
(when (xml-printable-as-subelement-p Element)
(map-object Element Function))))))
;; print which slots and what kinds of values?
(defmethod PRINT-SLOTS ((Self xml-serializer))
:all)
(defmethod PRINT-SLOT-WITH-NAME-P ((Self xml-serializer) Name)
(case Name
(content nil)
(t t)))
(defmethod XML-PRINTABLE-AS-SUBELEMENT-P ((Self t)) nil) ;; most general case => NO
(defmethod XML-PRINTABLE-AS-SUBELEMENT-P ((Self null)) nil)
(defmethod XML-PRINTABLE-AS-SUBELEMENT-P ((Self xml-serializer)) t)
(defmethod XML-PRINTABLE-AS-SUBELEMENT-P ((Self string)) nil)
(defmethod XML-PRINTABLE-AS-SUBELEMENT-P ((Self sequence)) t)
(defmethod XML-PRINTABLE-AS-SUBELEMENT-P ((Self array))
;; number arrays should not be printed as subelements
(not (and (array-element-type Self) (subtypep (array-element-type Self) 'number))))
(defmethod XML-PRINTABLE-AS-SUBELEMENT-P ((Self hash-table)) t)
(defmethod XML-PRINTABLE-AS-SUBELEMENT-P ((Self list))
(every #'xml-printable-as-subelement-p Self))
(defmethod XML-PRINTABLE-AS-ATTRIBUTE-VALUE-P ((Self t)) nil) ;; most general case => NO
(defmethod XML-PRINTABLE-AS-ATTRIBUTE-VALUE-P ((Self string)) t)
(defmethod XML-PRINTABLE-AS-ATTRIBUTE-VALUE-P ((Self number)) t)
(defmethod XML-PRINTABLE-AS-ATTRIBUTE-VALUE-P ((Self character)) t)
(defmethod XML-PRINTABLE-AS-ATTRIBUTE-VALUE-P ((Self symbol)) t)
(defmethod XML-PRINTABLE-AS-ATTRIBUTE-VALUE-P ((Self list)) t)
(defmethod XML-PRINTABLE-AS-ATTRIBUTE-VALUE-P ((Self pathname)) t)
(defmethod XML-PRINTABLE-AS-ATTRIBUTE-VALUE-P ((Self array))
;; number arrays can be printed
(and (array-element-type Self) (subtypep (array-element-type Self) 'number)))
(defmethod PRINT-SUBELEMENTS-TO-STREAM-P ((Self xml-serializer) Stream)
(declare (ignore Stream))
t)
(defmethod PRINT-DEFAULT-VALUE-ATTRIBUTES-P ((Self xml-serializer))
;; lean towards sparse representations
nil)
;; finished reading
(defmethod FINISHED-READING ((Self xml-serializer) Stream)
;; do nothing
(declare (ignore Stream))
)
(defmethod FINISHED-READING-ATTRIBUTES ((Self xml-serializer) Stream)
;; do nothing
(declare (ignore Stream))
)
(defmethod READ-RETURN-VALUE ((Self xml-serializer))
Self)
;______________________________
; compilation and load forms |
;______________________________
(defmethod MAKE-LOAD-FORM ((Self xml-serializer) &optional Environment)
;; if we want to compile files containing XML expression we better make some load forms
(make-load-form-saving-slots Self :environment Environment))
;*******************************************
;* User level Error handling *
;*******************************************
#+(or (not :mcl) :openmcl)
(defun SHOW-ERROR-IN-STREAM-TO-USER (Stream)
;; No generic Common Lisp solution
(declare (ignore Stream))
)
#+(and :mcl (not :openmcl))
(defun SHOW-ERROR-IN-STREAM-TO-USER (Stream)
;; YEAH, real luxury: Open up stream if it is a file in Fred editor and move cursor to problem location
(when (slot-exists-p Stream 'ccl::fblock)
(format t ";; attempting to open file containing error. Error Position: ~A..." (ccl::%fpos (slot-value Stream 'ccl::fblock)))
;; Open file in FRED and set cursor to location, scroll if necessary
(let ((Fred (ed (parse-namestring Stream))))
(ccl:set-mark (ccl:fred-buffer Fred) (ccl::%fpos (slot-value Stream 'ccl::fblock)))
(ccl:window-show-cursor Fred)
(ccl:fred-update Fred))))
;********************************************
;* Typed Attribute Value CODECs *
;* print encoded value into XML stream *
;* read decoded XML into internal format *
;********************************************
;_______________________________________
; default printer/reader: |
;_______________________________________
(defun TYPE-SPECIFIER-LIST-P (Type-Specifier)
"true if Type-Specifier is a type specifier list"
(and (listp Type-Specifier)
(symbolp (first Type-Specifier))))
(defun PRINT-SPECIFIER-LIST-TYPED-ATTRIBUTE-VALUE (Value Type-Specifier-List Stream)
;; try to handle type specifier lists (CLTL 4.2)
;; type specifier lists can be the result of subclasses adding types to existing slot types (and type1 type2 ...)
;; or types that are not supported as symbols in all CL implementations, e.g., boolean
(cond
((subtypep Type-Specifier-List '(member t nil))
(print-typed-attribute-value Value 'boolean Stream))
(t
(error "no print attribute method for type: ~A" Type-Specifier-List))))
(defmethod PRINT-TYPED-ATTRIBUTE-VALUE (Value (Type t) Stream)
(if (type-specifier-list-p Type)
(print-specifier-list-typed-attribute-value Value Type Stream)
(format
Stream
"\"~A\""
(etypecase Value
(string (encode-xml-string Value))
(number Value)
(symbol Value)
(list Value)))))
(defvar *Warn-if-undefined-XML-Decoder-Type* nil "set to t to get warnings")
(defun READ-SPECIFIER-LIST-TYPED-ATTRIBUTE-VALUE (Value Type-Specifier-List)
;; try to handle type specifier lists (CLTL 4.2)
;; type specifier lists can be the result of subclasses adding types to existing slot types (and type1 type2 ...)
;; or types that are not supported as symbols in all CL implementations, e.g., boolean
(cond
((subtypep Type-Specifier-List '(member t nil))
(read-typed-attribute-value Value 'boolean))
(t
(error "no read attribute method for type: ~A" Type-Specifier-List))))
(defmethod READ-TYPED-ATTRIBUTE-VALUE ((Value t) (Type t))
(cond
((type-specifier-list-p Type)
(read-specifier-list-typed-attribute-value Value Type))
(t
(when *Warn-If-Undefined-Xml-Decoder-Type*
(warn "no XML decoder for value \"~A\" of type \"~A\"" Value Type))
Value)))
;_____________________________________
; types and CODECs |
;_____________________________________
;; SYMBOL
(defmethod PRINT-TYPED-ATTRIBUTE-VALUE (Value (Type (eql 'symbol)) Stream)
(format Stream "\"~A\"" (symbol-name Value)))
(defmethod READ-TYPED-ATTRIBUTE-VALUE ((Value string) (Type (eql 'symbol)))
(intern (string-upcase Value)))
;; KEYWORD
(defmethod PRINT-TYPED-ATTRIBUTE-VALUE (Value (Type (eql 'keyword)) Stream)
(format Stream "\"~A\"" (symbol-name Value)))
(defmethod READ-TYPED-ATTRIBUTE-VALUE ((Value string) (Type (eql 'keyword)))
(intern (string-upcase Value) (find-package :keyword)))
;; STRING
(defmethod PRINT-TYPED-ATTRIBUTE-VALUE (Value (Type (eql 'string)) Stream)
(format Stream "\"~A\"" (encode-xml-string Value)))
(defmethod READ-TYPED-ATTRIBUTE-VALUE ((Value string) (Type (eql 'string)))
;; !!! should probably decode the string????
Value)
;; STRING-OR-NULL This is basically the same as not having a type
(deftype STRING-OR-NULL () "string or null" '(or string null))
(defmethod PRINT-TYPED-ATTRIBUTE-VALUE (Value (Type (eql 'string-or-null)) Stream)
(format Stream "\"~A\"" (encode-xml-string Value)))
(defmethod READ-TYPED-ATTRIBUTE-VALUE ((Value string) (Type (eql 'string-or-null)))
;; !!! should probably decode the string????
Value)
;; CHARACTER
(defmethod PRINT-TYPED-ATTRIBUTE-VALUE (Value (Type (eql 'character)) Stream)
(prin1 (encode-xml-string (string Value)) Stream))
(defmethod READ-TYPED-ATTRIBUTE-VALUE ((Value string) (Type (eql 'character)))
(char Value 0))
;; INTEGER
(defmethod PRINT-TYPED-ATTRIBUTE-VALUE (Value (Type (eql 'integer)) Stream)
(format Stream "\"~A\"" Value))
(defmethod READ-TYPED-ATTRIBUTE-VALUE ((Value string) (Type (eql 'integer)))
(parse-integer Value))
;; INTEGER-OR-NULL
(deftype INTEGER-OR-NULL () "string or null" '(or integer null))
(defmethod PRINT-TYPED-ATTRIBUTE-VALUE (Value (Type (eql 'integer-or-null)) Stream)
(format Stream "\"~A\"" Value))
(defmethod READ-TYPED-ATTRIBUTE-VALUE ((Value string) (Type (eql 'integer-or-null)))
(parse-integer Value))
;; NUMBER
(defmethod PRINT-TYPED-ATTRIBUTE-VALUE (Value (Type (eql 'number)) Stream)
(format Stream "\"~A\"" Value))
(defmethod READ-TYPED-ATTRIBUTE-VALUE ((Value string) (Type (eql 'number)))
(read-from-string Value))
;; BOOLEAN
(defmethod PRINT-TYPED-ATTRIBUTE-VALUE (Value (Type (eql 'boolean)) Stream)
(prin1 (if Value "true" "false") Stream))
(defmethod READ-TYPED-ATTRIBUTE-VALUE ((Value string) (Type (eql 'boolean)))
(if (string-equal Value "true") t nil))
;; FLOAT
(defmethod PRINT-TYPED-ATTRIBUTE-VALUE (Value (Type (eql 'float)) Stream)
(format Stream "\"~A\"" (coerce Value 'float)))
(defmethod READ-TYPED-ATTRIBUTE-VALUE ((Value string) (Type (eql 'float)))
(float (read-from-string Value)))
;; SHORT-FLOAT
(defmethod PRINT-TYPED-ATTRIBUTE-VALUE (Value (Type (eql 'short-float)) Stream)
(format Stream "\"~A\"" (coerce Value 'short-float)))
(defmethod READ-TYPED-ATTRIBUTE-VALUE ((Value string) (Type (eql 'short-float)))
(float (read-from-string Value) 0s0))
;; SINGLE-FLOAT
(defmethod PRINT-TYPED-ATTRIBUTE-VALUE (Value (Type (eql 'single-float)) Stream)
(format Stream "\"~A\"" (coerce Value 'single-float)))
(defmethod READ-TYPED-ATTRIBUTE-VALUE ((Value string) (Type (eql 'single-float)))
(float (read-from-string Value) 0s0))
;; DOUBLE-FLOAT
(defmethod PRINT-TYPED-ATTRIBUTE-VALUE (Value (Type (eql 'double-float)) Stream)
(format Stream "\"~F\"" Value))
(defmethod READ-TYPED-ATTRIBUTE-VALUE ((Value string) (Type (eql 'double-float)))
(float (read-from-string Value) 0d0))
;; PATHNAME
(defmethod PRINT-TYPED-ATTRIBUTE-VALUE (Value (Type (eql 'pathname)) Stream)
(prin1 (convert-to-unix-pathname Value) Stream))
(defmethod READ-TYPED-ATTRIBUTE-VALUE ((Value string) (Type (eql 'pathname)))
(convert-to-lisp-pathname Value))
;; PATH
(deftype PATH () "pathname or nil, externalized as unix style path" '(or pathname null))
(defmethod PRINT-TYPED-ATTRIBUTE-VALUE (Value (Type (eql 'path)) Stream)
(prin1 (convert-to-unix-pathname Value) Stream))
(defmethod READ-TYPED-ATTRIBUTE-VALUE ((Value string) (Type (eql 'path)))
(convert-to-lisp-pathname Value))
;; LIST
;; print as string is OK but internally keep as regular lisp list
(defmethod READ-TYPED-ATTRIBUTE-VALUE ((Value string) (Type (eql 'list)))
(read-from-string Value))
;; ARRAY
(defmethod PRINT-TYPED-ATTRIBUTE-VALUE (Value (Type (eql 'array)) Stream)
(unless (and (array-element-type Value) (subtypep (array-element-type Value) 'number))
(error "don't know how to print ~A in XML" Value))
(let ((Vector (make-array (array-total-size Value) :displaced-to Value :fill-pointer 0 :element-type 'short-float)))
;; store type and dimension
(format Stream "\"float array ~A " (array-dimensions Value))
;; dump numbers as flat vector
(dotimes (I (array-total-size Value))
(princ (aref Vector i) Stream)
(princ #\space Stream))
;; end
(princ #\" Stream)))
(defmethod READ-TYPED-ATTRIBUTE-VALUE ((Value string) (Type (eql 'array)))
(with-input-from-string (in Value)
(let ((Type (read In)))
(unless (equal Type 'float) (error "cannot special attribute type \"~A\"" Type))
(read In) ;; ignore array keyword
(let* ((Dimensions (read In))
(Array (make-array Dimensions :element-type 'short-float))
(Vector (make-array (array-total-size Array) :displaced-to Array :fill-pointer 0 :element-type 'short-float)))
(loop
(let ((Float (read In nil nil)))
(unless Float (return))
(vector-push Float Vector)))
(unless (= (fill-pointer Vector) (array-total-size Array))
(error "reading float array: expected to see ~A floats but found ~A" (array-total-size Array) (fill-pointer Vector)))
Array))))
;********************************************
;* Typed Subelement Value CODECs *
;* print encoded value into XML stream *
;********************************************
;_______________________________________
; default printer: warn |
;_______________________________________
(defmethod PRINT-TYPED-SUBELEMENT-VALUE ((Value t) (Type t) Stream)
;; (warn "no XML encoder for \"~A\" of type \"~A\"" Value Type)
;; do the same as with untyped subelements: map them
(map-object
Value
#'(lambda (Object)
(terpri Stream)
(print-object Object Stream))))
;*************************************
;* SGML-TAG Class *
;*************************************
(defclass SGML-TAG (xml-serializer)
()
(:documentation "SGML Tag. No sub elements, e.g., "))
(defmethod END-TAG-NAME-STRING ((Self sgml-tag))
">")
(defmethod READ-XMLISP-ELEMENT ((Self sgml-tag) Stream)
(setf (content Self) (read-until-token Stream (end-tag-name-string Self))) ;; no decoding
Self)
(defmethod PRINT-OBJECT ((Self sgml-tag) Stream)
(print-xml-indent Stream)
(format Stream "<~A ~A~A" (string-upcase (xml-tag-name-string Self)) (content Self) (end-tag-name-string Self))) ;; no encoding
;*************************************
;* ![CDATA[ Class *
;*************************************
(defclass ![CDATA[ (sgml-tag)
()
(:documentation "SGML uninterpreted content only class. Does not encode/decode strings"))
(defmethod END-TAG-NAME-STRING ((Self ![cdata[))
"]]>")
;*************************************
;* !DOCTYPE Class *
;*************************************
(defclass !DOCTYPE (sgml-tag)
()
(:documentation "SGML metadata"))
;*************************************
;* !-- Class *
;*************************************
(defclass !-- (sgml-tag)
()
(:documentation "SGML comment"))
(defmethod END-TAG-NAME-STRING ((Self !--))
"-->")
(defmethod PRINT-OBJECT ((Self !--) Stream)
(print-xml-indent Stream)
;; do NOT print a leading space before the content because this is a comment
(format Stream "<~A~A~A" (string-upcase (xml-tag-name-string Self)) (content Self) (end-tag-name-string Self))) ;; no encoding
;*************************************
;* xml-content Class *
;*************************************
(defclass XML-CONTENT (xml-serializer)
((name :accessor name :initform "untitled" :initarg :name :documentation "element tag name"))
(:documentation "Content elements have ONLY content: they may not hold sub element or attribute-based content, e.g., Copyright 2004, AgentSheets Inc."))
(defmethod XML-TAG-NAME-SYMBOL ((Self xml-content))
(name Self))
(defmethod PRINT-SLOT-WITH-NAME-P ((Self xml-content) Name)
(case Name
(name nil)
(t (call-next-method))))
;******************************
; MOP hacks *
; for Lisps with missing MOP *
; methods *
;******************************
;; this is the place where to put MOP hacks for different Lisp implementations
#+(and :mcl (not :ccl-5.1) (not :openmcl)) ;; MCL < 5.1 does not have this MOP function!
(defmethod CLASS-SLOTS ((Class standard-class))
;; Art of MOP: p. 214
;; pretty slow: don't use this if you don't have to
(coerce (rest (slot-value Class 'ccl::slots)) 'list))
(defmethod FIND-SLOT-DEFINITION ((Self xml-serializer) Name)
(find Name (class-slots (class-of Self)) :key #'slot-definition-name))
#+(and :mcl (not :openmcl) (not :ccl-5.1)) ;; the generic version would be very slow with MCL < 5.1
(defmethod FIND-SLOT-DEFINITION ((Self xml-serializer) Name)
(declare (optimize))
(let ((Slot-Definitions (rest (slot-value (class-of Self) 'ccl::slots))))
(dotimes (I (length Slot-Definitions))
(declare (fixnum i))
(let ((Slot-Definition (svref Slot-Definitions i)))
(when (eq (first Slot-Definition) Name) (return Slot-Definition))))))
(defun MOST-SPECIFIC-CLASS (Class) "
in: Class symbol or list: (and ... )
Return most specific class"
(typecase Class
(atom Class)
;; not clear if this is deterministic and same for all lisps
(list (first (last Class)))))
;_____________________________
; Symbol functions |
;_____________________________
(defun XMLISP-SYMBOL-NAME (Symbol)
(string-downcase (symbol-name Symbol)))
(defun READTABLE-STRING (Name) "
in: Name string.
out: Readtable-string string
Convert name string into symbol according to *Readtable*. Name cannot contain ':' "
(ecase (readtable-case *Readtable*)
(:upcase (string-upcase Name))
(:downcase (string-downcase Name))
(:preserve Name)
(:invert
(cond
((every #'upper-case-p Name) (string-downcase Name))
((every #'lower-case-p Name) (string-upcase Name))
(t Name)))))
(defun MAKE-XMLISP-SYMBOL (Name) "
in: Name string.
out: Symbol symbol.
Turn into taking into account the current readtable's case."
(let ((Colon-Position (position #\: Name)))
(if Colon-Position
(intern
(readtable-string (subseq Name (1+ Colon-Position)))
(or
;; read-from-string does the readtable stuff
;; slow but this is not used all that often
(find-package (intern (readtable-string (subseq Name 0 Colon-Position))))
(error "trying to read XML name \"~A\" but contains reference to non existing package." Name)))
(intern (readtable-string Name)))))
;_____________________________
; Pathname conversion |
;_____________________________
(defun DISK-NAME ()
(second (pathname-directory (truename "home:"))))
(defun SPLIT-STRING (String Splitter-Char)
(let ((Start 0)
(List nil))
(dotimes (I (length String) List)
(cond
;; splitter char
((char= (char String i) Splitter-Char)
(setq List (append List (list (subseq String Start I))))
(setq Start (+ i 1)))
;; the end
((= i (1- (length String)))
(setq List (append List (list (subseq String Start (1+ i))))))))))
(defun PARSE-FILE-NAME (Name)
(let ((Dot-Position (position #\. Name :from-end t)))
(if Dot-Position
(values
(subseq Name 0 Dot-Position)
(subseq Name (1+ Dot-Position)))
Name)))
(defun UNIX-PATHNAME-DIRECTORY-P (Unix-Pathname)
(char= (char Unix-Pathname (1- (length Unix-Pathname))) #\/))
(defun CONVERT-TO-UNIX-PATHNAME (Pathname)
(with-output-to-string (Unix-Pathname)
(dolist (Component (rest (rest (pathname-directory Pathname))))
(format Unix-Pathname "/~A" Component))
(cond
;; directory
((or (null (pathname-name Pathname))
(string-equal (pathname-name Pathname) ""))
(princ #\/ Unix-Pathname))
;; file
(t
(format Unix-Pathname "/~A" (pathname-name Pathname))
(when (pathname-type Pathname)
(format Unix-Pathname ".~A" (pathname-type Pathname)))))))
(defun CONVERT-TO-LISP-PATHNAME (Unix-Pathname)
(with-input-from-string (Path Unix-Pathname)
(unless (char= (read-char Path) #\/) (error "path needs to start with \"/\""))
(cond
((unix-pathname-directory-p Unix-Pathname)
(make-pathname
:directory (append (list :absolute (disk-name)) (rest (split-string Unix-Pathname #\/)))))
(t
(let ((Path-List (split-string Unix-Pathname #\/)))
(multiple-value-bind (Name Extension)
(parse-file-name (first (last Path-List)))
(make-pathname
:directory (append (list :absolute (disk-name)) (rest (butlast Path-List)))
:name Name
:type Extension)))))))
#+:CCL
(defun CONVERT-RELATIVE-UNIX-PATH-TO-LISP-PATHNAME (Unix-Pathname)
(with-input-from-string (Path Unix-Pathname)
(unless (char= (read-char Path) #\/) (error "path needs to start with \"/\""))
(cond
((unix-pathname-directory-p Unix-Pathname)
(make-pathname
:directory (append (pathname-directory (ccl:full-pathname "ccl:")) (rest (split-string Unix-Pathname #\/)))))
(t
(let ((Path-List (split-string Unix-Pathname #\/)))
(multiple-value-bind (Name Extension)
(parse-file-name (first (last Path-List)))
(make-pathname
:directory (append (pathname-directory (ccl:full-pathname "ccl:")) (rest (butlast (split-string Unix-Pathname #\/))))
:name Name
:type Extension)))))))
#| Test:
(convert-to-unix-pathname
(convert-to-lisp-pathname "/Users/alex/Desktop/enemy0.vat"))
(convert-to-unix-pathname
(convert-to-lisp-pathname "/Users/alex/Desktop/"))
|#
;_____________________________
; low level Read functions |
;_____________________________
(defvar *XML-Entity-Reference-Table*
'(("lt;" #\<) ("gt;" #\>) ("amp;" #\&) ("sq;" #\') ("apos;" #\') ("dq;" #\") ("quot;" #\") ("#10;" #\newline) ("#39;" #\'))
"http://www.w3.org/TR/WD-xml-961114.html#sec4.1")
(defun READ-UNTIL-TOKEN (Stream Token &key Escape-Char Decode-Function) "
in: Stream stream; Token string; &key Escape-Char char; Decode-Function stream->char.
out: String string.
Read from stream until token. If there is an escape-char use the decode-funtion to parse it."
(let ((String (make-array 40 :fill-pointer 0 :element-type 'character :adjustable t))
(Match 0)
(End (length Token)))
(loop
(let ((Char (read-char Stream nil nil)))
(cond
;; end of stream
((null Char) (return String))
;; Match!
((char= Char (char Token Match))
(incf Match)
;; are we done yet?
(when (= Match End) (return String)))
;; NO match
(t
;; resolve partial match
(dotimes (I Match)
(vector-push-extend (char Token i) String))
(setq Match 0)
(cond
;; escape character that needs decoding?
((and Escape-Char (char= Char Escape-Char) Decode-Function)
(vector-push-extend (funcall Decode-Function Stream) String))
;; legit part of string
(t
(vector-push-extend Char String)))))))))
(defun DECODE-XML-ENTITY-REFERENCE (Stream) "
If the XML escape character & has been encountered use this function to decode the rest of the entity reference"
(let* ((Name (read-until-token Stream ";")) ;; does not include "&" or ";"
(Entity-Reference (find Name *XML-Entity-Reference-Table*
:key #'first
:test #'(lambda (N1 N2) (string= N1 N2 :end2 (min (length N1) (length N2)))))))
(unless Entity-Reference
(error "\"&~A;\" is not a valid EntityRef. http://www.w3.org/TR/WD-xml-961114.html#sec4.1" Name))
(second Entity-Reference)))
(defun SKIP-UNTIL-CHARS (Stream &rest Chars) "
Find all chars in sequence and keep reading until last char of is found."
(dolist (Char Chars)
(loop
(when (char= Char (read-char Stream)) (return)))))
(defun DECODE-XML-STRING (String) "
in: String string.
out: Decoded-String string.
Decode XML ecoded strings back into litteral strings.
e.g., \"a > b\" turns into \"a > \"b"
(with-input-from-string (stream (if (stringp String) String (write-to-string String)))
(read-until-token Stream nil :escape-char #\& :decode-function #'decode-xml-entity-reference)))
(defun ENCODE-XML-STRING (String) "
Convert String to an XML-compatible string:
\"<\" becomes \"<\"
\">\" becomes \">\"
\"&\" becomes \"&\"
\" becomes \""\"
\"'\" becomes \"'\"
and the newline character becomes \"
\""
;; should use *XML-ENTITY-REFERENCE-TABLE*
(unless (stringp String) (setq String (write-to-string String))) ;; just in case
(let ((Output (make-array 40 :fill-pointer 0 :element-type 'character :adjustable t)))
(with-input-from-string (Input String)
(loop
(let ((Char (or (read-char Input nil nil) (return Output))))
(case Char
(#\<
(vector-push-extend #\& Output)
(vector-push-extend #\l Output)
(vector-push-extend #\t Output)
(vector-push-extend #\; Output))
(#\>
(vector-push-extend #\& Output)
(vector-push-extend #\g Output)
(vector-push-extend #\t Output)
(vector-push-extend #\; Output))
(#\&
(vector-push-extend #\& Output)
(vector-push-extend #\a Output)
(vector-push-extend #\m Output)
(vector-push-extend #\p Output)
(vector-push-extend #\; Output))
(#\newline
(vector-push-extend #\& Output)
(vector-push-extend #\# Output)
(vector-push-extend #\1 Output)
(vector-push-extend #\0 Output)
(vector-push-extend #\; Output))
(#\"
(vector-push-extend #\& Output)
(vector-push-extend #\q Output)
(vector-push-extend #\u Output)
(vector-push-extend #\o Output)
(vector-push-extend #\t Output)
(vector-push-extend #\; Output))
(#\'
(vector-push-extend #\& Output)
(vector-push-extend #\# Output)
(vector-push-extend #\3 Output)
(vector-push-extend #\9 Output)
(vector-push-extend #\; Output))
(t
(vector-push-extend Char Output))))))))
;________________________________________
; Token level Reader functions |
;________________________________________
(defun SKIP-XML-HEADER (Stream) "
For now we do not do anything with the header content but just make sure we skip it."
(let ((Char (read-char Stream)))
(unless (char= Char #\?) (return-from skip-xml-header (unread-char Char Stream)))
(skip-until-chars Stream #\? #\> #\<)))
(defun READ-XMLISP-NAME (Stream) "
Valid names start with a letter, _ or :, have to contain letters or digits or other valid characters (see XML spec).
Extended with SGML spec. allowing names such as'
(vector-push-extend Char Name)
(loop
(let ((Char (read-char Stream)))
(cond
;; complete: return as symbol
((or (white-space-p Char)
(char= Char #\=)
(char= Char #\>)
(char= Char #\/))
(unread-char Char Stream)
(return (values (make-xmlisp-symbol Name)
Name)))
;; comment: do not wait for delimiter http://www.w3.org/TR/REC-xml/#sec-comments
((and (char= Char #\-) (string= Name "!-"))
(vector-push-extend Char Name)
(return (values (make-xmlisp-symbol Name)
Name)))
;; part of name
((or (namecharp Char)
(char= Char #\[)) ;; SGML
(vector-push-extend Char Name))
;; trouble
(t
(show-error-in-stream-to-user Stream)
(error "Character ~C is not a valid character for a name" Char))))))
(t
(show-error-in-stream-to-user Stream)
(error "Not a valid start character for name")))))
(defun READ-XMLISP-VALUE (Stream)
;; read single and double quote values
(case (read-char Stream)
(#\"
(read-until-token Stream "\"" :escape-char #\& :decode-function #'decode-xml-entity-reference))
(#\'
(read-until-token Stream "\'" :escape-char #\& :decode-function #'decode-xml-entity-reference))
(t
(show-error-in-stream-to-user Stream)
(error "not a valid XML value"))))
(defmethod READ-XMLISP-CHARACTER-CONTENT ((Self xml-serializer) Stream)
(prog1
(read-until-token Stream "<" :escape-char #\& :decode-function #'decode-xml-entity-reference)
(unread-char #\< Stream)))
(defun READ-NAME-AND-MAKE-INSTANCE (Stream) "
If name corresponds to an existing class create an instance that of that instance.
Search strategy:
1) look in element-class-name table
2) look for class with symbol-name matching original case
3) look for class with symbol-name matching readtable case converted (probably all uppercase) case
4) create a much more constrained xml-content instance"
(read-return-value
(multiple-value-bind (Symbol String)
(read-xmlisp-name Stream)
(let ((Element-Class-Name (element-class-name Symbol))
(Original-Case-Symbol (find-symbol String)))
(cond
;; 1) lookup element class name table
(Element-Class-Name
;; if this name is in the table we should interpret lack of class to be an error
(if (find-class Element-Class-Name nil)
(make-instance Element-Class-Name)
(error "element \"~A\" cannot produce instance of class \"~A\" because that class does not exist" String Element-Class-Name)))
;; 2) Original Case matches class name
((and Original-Case-Symbol (find-class Original-Case-Symbol nil))
(make-instance Original-Case-Symbol))
;; 3) readtable translated case matches class name
((find-class Symbol nil)
(make-instance Symbol))
;; 4) xml-content
(t
(make-instance
(if *Fallback-Class-Name-For-Element-Name-Hook*
(or (funcall *fallback-class-name-for-element-name-hook* Symbol)
'xml-content)
'xml-content)
:name Symbol)))))))
(defun READ-WHITE-SPACE (Stream)
(let ((Char nil))
(loop
(or (setq Char (read-char Stream nil nil)) (throw :read-element-error nil))
(unless (white-space-p Char)
(unread-char Char Stream)
(return t)))))
(defun READ-EQUAL-SIGN (Stream)
(read-white-space Stream)
(let ((Char (or (read-char Stream nil nil) (throw :read-element-error nil))))
(if (char= Char #\=)
(read-white-space Stream)
(format-if-verbose t "Did not find an equal sign"))))
(defmethod READ-XMLISP-ATTRIBUTES ((Self xml-serializer) Stream)
(read-white-space Stream)
(loop
(let ((Char (read-char Stream)))
(case Char
((#\/ #\>) ;; delimiters
(unread-char Char Stream)
(finished-reading-attributes Self Stream)
(return))
(t
(unread-char Char Stream)
(read-white-space Stream)
(set-attribute-value Self (prog1 (read-xmlisp-name Stream) (read-equal-sign Stream)) (read-xmlisp-value Stream))
(read-white-space Stream)))))
(finished-reading-attributes Self Stream) ;; not that important any more: just specialize initialize-instance
Self)
(defmethod READ-XMLISP-ELEMENT-CONTENT ((Self xml-serializer) Stream)
(let ((Char (read-char Stream)))
(case Char
;; found an empty element or the end of this element
(#\/
(unread-char Char Stream)
(return-from read-xmlisp-element-content nil))
;; start a new sub element
(t
(unread-char Char Stream)
(let ((Element (read-name-and-make-instance Stream)))
(add-subobject Self Element)
(setf (part-of Element) Self))
Self))))
(defmethod READ-XMLISP-END-TAG ((Self xml-serializer) Stream)
(let ((End-Tag (read-xmlisp-name Stream)))
(read-white-space Stream)
(case (read-char Stream)
(#\> ;; match tags
(if (eq (xml-tag-name-symbol Self) End-Tag)
(return-from read-xmlisp-end-tag t)
(error "Tag mismatch: start tag=~A end tag=~A" (xml-tag-name-symbol Self) End-Tag)))
(t
(error "Not a well formed end tag. Missing '>'")))))
(defmethod READ-XMLISP-ELEMENT ((Self xml-serializer) Stream)
;; assume name & attributes have been read
;; we are just about to read the end of the first part of the element ">" or "/>"
;; (format t "read-xmlisp-element ~A~%" (type-of self))
(let (($Sub-Element-Slot-Names$ nil))
(declare (special $Sub-Element-Slot-Names$))
(loop
(read-white-space Stream)
(let ((Char (read-char Stream)))
(case Char
;; end of element
(#\/
(case (read-char Stream)
(#\> ;; DONE!
(return-from read-xmlisp-element Self))
(t
(error "Not a well formed end tag. Missing '>'"))))
;; end tag
(#\<
(case (read-char Stream)
(#\/
(when (read-xmlisp-end-tag Self Stream)
(cleanup-sub-object-slots Self $Sub-Element-Slot-Names$)
(return-from read-xmlisp-element Self)))
(t
(error "Not a well formed end tag. Missing '/'"))))
;; content
(#\>
(loop
(read-white-space Stream)
(let ((Next-Char (read-char Stream)))
(case Next-Char
(#\<
(unless (read-xmlisp-element-content Self Stream)
(case (read-char Stream)
(#\/
(when (read-xmlisp-end-tag Self Stream)
(cleanup-sub-object-slots Self $Sub-Element-Slot-Names$)
(return-from read-xmlisp-element Self)))
(t (error "Not a well formed end tag. Missing '/'")))))
(t
(unread-char Next-Char Stream)
;; append to existing content
(setf (content Self)
(if (content Self)
(concatenate
'string
(content Self)
(read-xmlisp-character-content Self Stream))
(read-xmlisp-character-content Self Stream)))))))))))))
(defmethod READ-XMLISP-ELEMENT :after ((Self xml-serializer) Stream)
;; call finished-reading in a new empty dynamic context
;; to make sure it does not mess up current one
;; this could be a problem if finished-reading called more xml read functions
(let (($Sub-Element-Slot-Names$ nil))
(declare (special $Sub-Element-Slot-Names$))
(finished-reading Self Stream)))
;_____________________________
; Initialization |
;_____________________________
(defmethod INITIALIZE-INSTANCE ((Self xml-serializer) &rest Args)
(declare (ignore Args) (special |$xml-stream$|))
(call-next-method)
;; if this instance has been created through the XML reader then
;; read its attributes and set its slots
(when (boundp '|$xml-stream$|)
(read-xmlisp-attributes Self |$xml-stream$|))
Self)
(defmethod INITIALIZE-INSTANCE :after ((Self xml-serializer) &rest Args)
(declare (ignore Args) (special |$xml-stream$|))
;; if this instance has been created through the XML reader then
;; read its content & sub elements if there are any
(when (boundp '|$xml-stream$|)
(read-xmlisp-element Self |$xml-stream$|))
Self)
;_____________________________
; File Input/Output |
;_____________________________
(defun LOAD-OBJECT (Filename &key Verbose (If-Does-Not-Exist :error) (Package *Package*)) "
in: Filename pathname;
&key Verbose boolean;
if-does-not-exist action default :error;
package package default *Package*.
out: Object t.
Load XML object contained in into package and return it."
(when Verbose (format t ";; loading object in file: ~A~%" Filename))
(let ((*Package* Package))
(with-open-file (File Filename :direction :input :if-does-not-exist If-Does-Not-Exist)
(let ((*Xml-Stream* File))
(declare (special *Xml-Stream*))
(let ((Object (read File)))
(setf (file Object) Filename)
Object)))))
(defmethod SAVE-OBJECT ((Self xml-serializer) Filename &key Verbose (If-Exists :error) (Xml-Header ""))
(when Verbose (format t ";; saving object to file: ~A~%" Filename))
(with-open-file (File Filename :direction :output :if-exists If-Exists)
(when XML-Header (format File "~A~%" XML-Header))
(princ Self File)))
;_____________________________
; Set & Aggregation Handlers |
;_____________________________
(defvar *Plural-Name-Table* (make-hash-table :test #'eq) "cached plural forms of symbols, e.g., bla -> blas")
(defun PLURAL-NAME (Name) "
in: name symbol.
out: plural-form-of-name symbol.
Return plural form of "
(or (gethash Name *Plural-Name-Table*)
(setf (gethash Name *Plural-Name-Table*) (make-xmlisp-symbol (format nil "~As" Name)))))
(defmethod SLOT-NAME->ATTRIBUTE-NAME ((Self xml-serializer) Slot-Name)
;; default to identity
Slot-Name)
(defmethod ATTRIBUTE-NAME->SLOT-NAME ((Self xml-serializer) Attribute-Name)
;; default to identity
Attribute-Name)
(defmethod SET-ATTRIBUTE-VALUE ((Self xml-serializer) Name Value)
;; (format t "~%set attribute: ~A to: ~A" Name Value)
;; use MOP to find suitable slot with matching symbol-name
(declare (special *Xml-Stream*))
(let* ((Slot-Definition (or (find-slot-definition Self (attribute-name->slot-name Self Name))
(when (boundp '*Xml-Stream*) (show-error-in-stream-to-user *Xml-Stream*))
(error "class: ~A does not have slot matching attribute name: ~A" (type-of Self) Name)))
(Type (slot-definition-type Slot-Definition)))
(setf (slot-value Self (slot-definition-name slot-definition))
(if (eq Type t)
;; super generic type: need to explore other aspects of slot-definition
(cond
;; try to infer from type of :initform
((numberp (slot-definition-initform Slot-Definition))
(read-from-string Value))
;; no clues: fill in as string
(t
Value))
;; dispatch based on type
(read-typed-attribute-value Value Type)))))
(defmethod ADD-OBJECT-TO-SLOT ((Self xml-serializer) Object Slot-Name)
(declare (special $Sub-Element-Slot-Names$))
;; not very clever: needs to be reversed in cleanup
(when (boundp '$Sub-Element-Slot-Names$)
(pushnew Slot-Name $Sub-Element-Slot-Names$)) ;; keep track of slots for cleanup
(push Object (slot-value Self Slot-Name)))
(defmethod CLEANUP-SUB-OBJECT-SLOTS ((Self xml-serializer) Slot-Names)
;; reverse lists to preserve same order as in stream
(dolist (Slot-Name Slot-Names)
(setf (slot-value Self Slot-Name) (reverse (slot-value Self Slot-Name)))))
(defmethod ADD-SUBOBJECT ((Self xml-serializer) Object)
(let ((Name (xml-tag-name-symbol Object)))
(let ((Single-Value-Slot-Definition (find-slot-definition Self Name)))
(if Single-Value-slot-definition
(setf (slot-value Self (slot-definition-name Single-Value-slot-definition)) Object)
(let ((Multy-Value-Slot-Definition (find-slot-definition Self (plural-name Name))))
(if Multy-Value-slot-definition
(add-object-to-slot Self Object (slot-definition-name Multy-Value-slot-definition))
(error "element: ~A of class: ~A does not have slots (\"~A\" or \"~A\") to contain sub element: ~A of class: ~A"
(xml-tag-name-symbol Self)
(type-of Self)
Name
(plural-name Name)
Name
(type-of Object))))))))
(defmethod (SETF PART-OF) (Container (Self xml-serializer))
(declare (ignore Container))
;; do nothing
)
(defmethod PART-OF ((Self xml-serializer))
;; to return object containing me we would need a part-of slot to store it
nil)
;_____________________________
; File |
;_____________________________
(defmethod (SETF FILE) (Container (Self xml-serializer))
(declare (ignore Container))
;; do nothing
)
(defmethod FILE ((Self xml-serializer))
;; by default we are not storing this information. Add a file slot to you object if you needs this
nil)
;_____________________________
; Print |
;_____________________________
(defun NUMBER-OF-PRINTABLE-ELEMENTS (Object) "
Retun the number of object components that can be printed as XML elements."
(let ((Number 0))
(map-object
Object
#'(lambda (Element)
(when (xml-printable-as-subelement-p Element)
(incf Number))))
Number))
(defvar *XML-Tab-Level* 0 "level of indentation")
(defun PRINT-XML-INDENT (Stream &optional (Level *XML-Tab-Level*))
(dotimes (I Level)
(princ " " Stream)))
(defmethod PRINT-SLOT-NAME-VALUE-TYPE-AS-ATTRIBUTE ((Self xml-serializer) Name Value Type Stream)
(format Stream " ~A=" (string-downcase (symbol-name Name)))
(print-typed-attribute-value Value Type Stream))
(defmethod PRINT-SLOT-VALUE-AS-ATTRIBUTE ((Self xml-serializer) Slot-Definition Stream)
(print-slot-name-value-type-as-attribute
Self
(slot-name->attribute-name Self (slot-definition-name slot-definition))
(slot-value Self (slot-definition-name slot-definition))
(slot-definition-type slot-definition)
Stream))
(defmethod PRINT-SLOTS-AS-ATTRIBUTES ((Self xml-serializer) Slot-Definitions Stream)
(dolist (Slot-Definition slot-definitions)
(let ((Value (slot-value Self (slot-definition-name slot-definition))))
;; make sure there is a meaninful way to print the value
(when (or (print-default-value-attributes-p Self)
(not (equal Value (slot-definition-initform slot-definition))))
(print-slot-value-as-attribute Self slot-definition Stream)))))
(defmethod PRINT-SLOT-VALUE-AS-SUBELEMENT ((Self xml-serializer) Slot-Definition Stream)
(let ((Type (slot-definition-type slot-definition))
(Value (slot-value Self (slot-definition-name slot-definition))))
(if Type
;; Typed
(print-typed-subelement-value Value Type Stream)
;; untyped
(map-object
Value
#'(lambda (Object)
(terpri Stream)
(print-object Object Stream))))))
(defmethod PRINT-SLOTS-AS-SUBELEMENTS ((Self xml-serializer) Slot-Definitions Stream)
(dolist (Slot-Definition slot-definitions)
;; (format t "~%print slot: ~A" (slot-definition-name slot-definition))
(print-slot-value-as-subelement Self slot-definition Stream)))
(defmethod SLOTS-TO-PRINT-LIST ((Self xml-serializer))
(let ((Slot-Names (print-slots Self)))
(if (equal Slot-Names :all)
(class-slots (class-of Self))
(mapcar
#'(lambda (Slot-Name)
(or (find-slot-definition Self Slot-Name)
;; if slot definition is not found return slot-name, caller could try to find accessor function
Slot-Name))
Slot-Names))))
(defmethod print-accessor-values-as-attributes ((Self xml-serializer) Accessor-Values Stream)
(dolist (Accessor-Value Accessor-Values)
;; we have little meta information: no type, initform etc.
(format Stream " ~A=" (string-downcase (first Accessor-Value)))
(print-typed-attribute-value (rest Accessor-Value) t Stream)))
(defmethod print-accessor-values-as-subelements ((Self xml-serializer) Accessor-Values Stream)
(dolist (Accessor-Value Accessor-Values)
(map-object
(rest Accessor-Value)
#'(lambda (Object)
(terpri Stream)
(print-object Object Stream)))))
(defmethod PRINT-OBJECT ((Self xml-serializer) Stream)
;; start tag
(print-xml-indent Stream)
(format Stream "<~A" (xml-tag-name-string Self))
;; separate printable subelements from others
(let ((Attribute-Value-Printable-Slot-Definitions nil)
(Subelement-Printable-Slot-Definitions nil)
(Accessor-Based-Attribute-Values nil)
(Accessor-Based-Subelement-Values nil))
;; sort out into attribute/subelements and slot/accessor based values
(dolist (Slot-Definition (reverse (slots-to-print-list Self)))
(typecase Slot-Definition
(symbol
;; problem: there is no such slot, slot-definition is name that may have matching accessor function
;; this should be rare
(let ((Name Slot-Definition))
(when (print-slot-with-name-p Self Name)
(if (and (fboundp Name)
(eq (type-of (symbol-function Name)) 'STANDARD-GENERIC-FUNCTION)
(compute-applicable-methods (symbol-function Name) (list Self))) ;; MOP function
(let ((Value (funcall (symbol-function Name) Self)))
;; we have little meta information: no type, initform etc.
;; NIL is probably not very usefull
(when Value
(if (xml-printable-as-subelement-p Value)
(push (cons Name Value) Accessor-Based-Subelement-Values)
(push (cons Name Value) Accessor-Based-Attribute-Values))))
(error "print error: Class \"~A\" does not have slot \"~A\"" (type-of Self) Name)))))
;; must be a valid slot definition
(t
(when (print-slot-with-name-p Self (slot-definition-name slot-definition))
(let ((Value (slot-value Self (slot-definition-name slot-definition))))
(cond
;; subelement
((xml-printable-as-subelement-p Value)
(push slot-definition Subelement-Printable-slot-definitions))
;; non-t slot definition type: assume it's printable or there is CODED
((not (eq (slot-definition-type Slot-Definition) t))
(push slot-definition Attribute-Value-Printable-slot-definitions))
;; attribute
((xml-printable-as-attribute-value-p Value)
(push slot-definition Attribute-Value-Printable-slot-definitions))
(t
(warn "\"~A\" stored in slot ~A is not XML printable" Value (slot-definition-name slot-definition)))))))))
;; print single <.../> or nested one
(cond
;; at least one sub element or some content
((and (print-subelements-to-stream-p Self Stream)
(or Subelement-Printable-slot-definitions
Accessor-Based-Subelement-Values
(content Self)))
;; start tag
(print-slots-as-attributes Self Attribute-Value-Printable-slot-definitions Stream)
(print-accessor-values-as-attributes Self Accessor-Based-Attribute-Values Stream)
(format Stream ">")
;; content
(when (content Self) (princ (encode-xml-string (content Self)) Stream))
;; sub elements
(let ((*Xml-Tab-Level* (1+ *XML-Tab-Level*)))
(print-slots-as-subelements Self Subelement-Printable-slot-definitions Stream)
(print-accessor-values-as-subelements Self Accessor-Based-Subelement-Values Stream))
;; end tag
(unless (content Self)
(terpri Stream)
(print-xml-indent Stream))
(format Stream "" (xml-tag-name-string Self)))
;; simple tag: no sub elements, no content
(t
(print-slots-as-attributes Self Attribute-Value-Printable-slot-definitions Stream)
(print-accessor-values-as-attributes Self Accessor-Based-Attribute-Values Stream)
(format Stream "/>")))))
;_____________________________
; Reader |
;_____________________________
(defun ELEMENT-READER (Stream Char)
(declare (ignore Char))
;; may not be an XML element after all, e.g., common-lisp functions <, <=
(let ((Next-Char (read-char Stream nil nil)))
;; danger zone: may not catch all the cases.
;; Probably better approach: if next-char is not a valid first character of a XML element name then
;; finish reading the symbol and return it
(case Next-Char
(#\space
(unread-char Next-Char Stream)
(return-from element-reader (values (intern "<"))))
(#\= (return-from element-reader (values (intern "<="))))
(#\)
(unread-char Next-Char Stream)
(return-from element-reader (values (intern "<")))))
(unread-char Next-Char Stream))
;; lets read XML
(skip-xml-header Stream) ;; this only needs to be done once
(let ((|$xml-stream$| Stream))
(declare (special |$xml-stream$|))
(read-name-and-make-instance Stream)))
(defvar *XMLisp-Packages* :all "define which packages support the XML reader: list of packages, nil or keyword :all. Default is :all")
;; error if XMLisp has not been loaded but there already is a #\< reader
;; there can only be one such reader
(eval-when (:compile-toplevel :load-toplevel :execute)
(when (and (not (boundp '*Non-XMLISP-Readtable*)) (get-macro-character #\<))
(warn "~%XMLisp: The current *readtable* already contains a #/< reader function: ~A" (get-macro-character #\<))))
(defvar *Non-XMLISP-Readtable* (copy-readtable *Readtable*) "A readtable not including the XMLisp #\< reader")
(defvar *XMLisp-Reader-Enabled* t "if nil then no XML reading will take place")
(defmacro WITHOUT-XML-READER (&body Code)
(let ((Enabled-Var (gensym)))
`(let ((,Enabled-Var *Xmlisp-Reader-Enabled*))
(unwind-protect
(progn
(setq *Xmlisp-Reader-Enabled* nil)
,@Code)
(setq *Xmlisp-Reader-Enabled* ,Enabled-Var)))))
(defun PACKAGE-DEPENDENT-ELEMENT-READER (Stream Char)
(if (and *XMLisp-Reader-Enabled*
(or (eq *XMLisp-Packages* :all)
(and (listp *XMLisp-Packages*)
(member *Package* *XMLisp-Packages*))))
;; XML
(funcall #'element-reader Stream Char)
;; non XML
(let ((*Readtable* *Non-XMLISP-Readtable*))
(unread-char Char Stream)
(read Stream))))
(set-macro-character #\< #'package-dependent-element-reader t)
;_____________________________
; Platform Specific Printing |
;_____________________________
#+(and :mcl (not :openmcl))
(defmethod PRINT-SUBELEMENTS-TO-STREAM-P ((Self xml-serializer) (Stream inspector::cache-entry-stream))
;; never print sublelements in inspector
(declare (ignore Stream))
nil)
#+(and :mcl (not :openmcl))
(defmethod PRINT-SLOT-VALUE-AS-SUBELEMENT ((Self xml-serializer) Slot-Definition (Stream ccl::terminal-io))
(let ((Value (slot-value Self (slot-definition-name slot-definition))))
;; in Listener only print all subelements if there are not that many
(cond
((<= (number-of-printable-elements Value) 100)
(call-next-method))
;; too many!!
(t
(terpri Stream)
(print-xml-indent Stream)
(format Stream "... with ~A ~A subelements ..." (number-of-printable-elements Value) (slot-definition-name slot-definition))))))
#+(and :mcl (not :openmcl))
(defmethod PRINT-TYPED-ATTRIBUTE-VALUE (Value (Type (eql 'array)) (Stream ccl::terminal-io))
(unless (and (array-element-type Value) (subtypep (array-element-type Value) 'number))
(error "don't know how to print ~A in XML" Value))
;; store type and dimension
(format Stream "\"float array ~A, ~A values ...\"" (array-dimensions Value) (array-total-size Value)))
#|
;; Example 1: HTML Link
;; simple mapping between class/element and slot/attribute name
(defclass A (xml-serializer)
((href :accessor href :initform "" :initarg :href))
(:documentation "HTML link"))
(inspect )
(read-from-string "AgentSheets")
(href XMLisp examples)
;; Example 2: RSS
(defclass RSS (xml-serializer)
((version :accessor version :initform "")
(channel :accessor channel :initform nil))
(:documentation "RSS main element"))
(defclass CHANNEL (xml-serializer)
((title :accessor title :initform "")
(link :accessor link :initform "")
(description :accessor description :initform "")
(image :accessor image :initform nil)
(managingeditor :accessor managingeditor :initform "")
(ttl :accessor ttl :initform nil :documentation "don't know what this is")
(language :accessor language :initform "")
(copyright :accessor copyright :initform "")
(webmaster :accessor webMaster :initform "")
(pubdate :accessor pubDate :initform "")
(lastbuilddate :accessor lastBuildDate :initform "")
(category :accessor category :initform "")
(generator :accessor generator :initform "")
(docs :accessor docs :initform "")
(items :accessor items :initform nil :documentation "list of RSS item"))
(:documentation "RSS channel"))
(defclass IMAGE (xml-serializer)
((title :accessor title :initform "")
(url :accessor url :initform "")
(link :accessor link :initform "")
(width :accessor width :initform 0))
(:documentation "RSS Image"))
(defclass ITEM (xml-serializer)
((title :accessor title :initform "")
(link :accessor link :initform "")
(description :accessor description :initform "")
(pubdate :accessor pubdate :initform ""))
(:documentation "RSS news Item"))
;; pick an XML RSS file from the examples/xml folder
;; if you pick other RSS files keep in mind that the above spec is incomplete
(defparameter *RSS-News* (load-object (ccl:choose-file-dialog)))
(save-object *RSS-News* "ccl:delete_me.xml" :if-exists :overwrite)
;; and walk throught the RSS structure
(inspect *RSS-News*)
;; Example 3: Typed Slots
;; Typed slots use the print-typed-attribute-value, read-typed-attribute-value, print-typed-subelement-value
;; CODECs
(defclass COIN (xml-serializer)
((head-is-up :accessor head-is-up :type boolean)))
(inspect )
;; Example 4: simple Aggregation: rule based Visual AgenTalk-like language
;; use MOP name matching to implement aggregation
;; e.g. slot "RULES" will contain a list of "RULE" elements
(defclass COMMAND (xml-serializer)
((name :accessor name :initform "" :initarg :name)
(comments :accessor comments :initform nil)))
(defclass BEHAVIOR (command)
((method-commands :accessor method-commands :initform nil)))
(defclass METHOD-COMMAND (command)
((trigger :accessor trigger :initform nil)
(rules :accessor rules :initform nil)))
(defclass TRIGGER (command)
())
(defclass RULE (command)
((condition-commands :accessor condition-commands :initform nil :initarg :condition-commands)
(action-commands :accessor action-commands :initform nil :initarg :action-commands)
(is-enabled :accessor is-enabled :initform t :initarg :is-enabled :type boolean)
(probablility :accessor probability :initform 0.9s0 :initarg :probability :type short-float)))
(defclass CONDITION-COMMAND (command)
())
(defclass ACTION-COMMAND (command)
())
(inspect
)
;; Example 5: User defined Aggregation
;; This is by no means a complete definition
(defclass HTML-BASE-CLASS (xml-serializer)
()
(:documentation "mother of all HTML element classes"))
(defclass HTML (html-base-class)
((items :accessor items :initform nil))
(:documentation "Contains all the html items of an HTML document"))
(defmethod ADD-SUBOBJECT ((Self html) (Item html-base-class))
;; extend this method to add all html-base-class instances to the "items" slot
(add-object-to-slot Self Item 'items))
(defclass A (html-base-class)
((href :accessor href :initform "" :initarg :href))
(:documentation "HTML link"))
(defclass FONT (html-base-class)
((face :accessor face)
(size :accessor size :type number))
(:documentation "Font info"))
(inspect
Small Text here
Large Text here
Go CU
)
;;; Example 6: specialized attribute/slot name mapping
(defclass ARGUMENT (xml-serializer)
((pros :accessor pros :initform nil)
(against :accessor against :initform nil))) ;; cons would be slot name that would conflict with Common Lisp symbol
(defmethod ATTRIBUTE-NAME->SLOT-NAME ((Self argument) Attribute-Name)
(case Attribute-Name
(cons 'against)
(t (call-next-method))))
(defmethod SLOT-NAME->ATTRIBUTE-NAME ((Self argument) Slot-Name)
(case Slot-Name
(against 'cons)
(t (call-next-method))))
;; still works: could overwrite that if needed
(against )
;;; Example 7: Name spaces
;;; XML Name spaces map to Lisp Packages
;;; if you need to be able to read, say,
;; define packages if they do not already exist:
(defpackage PIKIM)
(defpackage XMLNS)
;; then define your element class including slot names and accessors with package prefixes:
(defclass SIMULATION (xml-serializer)
((pikim::content_type :accessor pikim::content_type :initform nil)
(xmlns::pikim :accessor xmlns::pikim :initform nil)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Example 8: comments, http://www.w3.org/TR/REC-xml/#sec-comments
;; well formed: (content )
;; not well formed:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Example 9: printing attributes based on accessor instead of slots
(defclass class-with-missing-slot (xml-serializer)
())
(defmethod print-slots ((Self class-with-missing-slot))
'(accessor-with-no-matching-slot)) ; note: class does not have this slot
(defmethod accessor-with-no-matching-slot ((Self class-with-missing-slot))
55)
(setq c (make-instance 'class-with-missing-slot))
(defclass list-of-class-with-missing-slot (xml-serializer)
((stuff :accessor stuff :initform 0 :type number :initarg :stuff)))
(defmethod elements ((Self list-of-class-with-missing-slot))
(let ((List nil))
(dotimes (i 20 List)
(push (make-instance 'class-with-missing-slot) List))))
(defmethod print-slots ((Self list-of-class-with-missing-slot))
'(stuff elements))
(defparameter *lc* (make-instance 'list-of-class-with-missing-slot :stuff 111))
(stuff *lc*)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Example 10: Read return values
(defclass SUM (xml-serializer)
((a :accessor a :type number)
(b :accessor b :type number)))
(defmethod READ-RETURN-VALUE ((Self sum))
;; overwrite: instead of returning self return the actual sum of a and b
(+ (a Self) (b Self)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Example 11: Keyword type
(defclass REFERENCE (xml-serializer)
((name :accessor name :type keyword)))
(name )
|#