--- /dev/null
+! Copyright (C) 2005, 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: xml.dispatch
+
+ABOUT: "xml.dispatch"
+
+ARTICLE: "xml.dispatch" "Dispatch on XML tag names"
+"Two parsing words define a system, analogous to generic words, for processing XML. A word can dispatch off the name of the tag that is passed to it. To define such a word, use"
+{ $subsection POSTPONE: PROCESS: }
+"and to define a new 'method' for this word, use"
+{ $subsection POSTPONE: TAG: } ;
+
+HELP: PROCESS:
+{ $syntax "PROCESS: word" }
+{ $values { "word" "a new word to define" } }
+{ $description "creates a new word to process XML tags" }
+{ $see-also POSTPONE: TAG: } ;
+
+HELP: TAG:
+{ $syntax "TAG: tag word definition... ;" }
+{ $values { "tag" "an xml tag name" } { "word" "an XML process" } }
+{ $description "defines what a process should do when it encounters a specific tag" }
+{ $examples { $code "PROCESS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } }
+{ $see-also POSTPONE: PROCESS: } ;
--- /dev/null
+! Copyright (C) 2005, 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: xml io kernel math sequences strings xml.utilities
+tools.test math.parser xml.dispatch ;
+IN: xml.dispatch.tests
+
+PROCESS: calculate ( tag -- n )
+
+: calc-2children ( tag -- n n )
+ children-tags first2 [ calculate ] dip calculate ;
+
+TAG: number calculate
+ children>string string>number ;
+TAG: add calculate
+ calc-2children + ;
+TAG: minus calculate
+ calc-2children - ;
+TAG: times calculate
+ calc-2children * ;
+TAG: divide calculate
+ calc-2children / ;
+TAG: neg calculate
+ children-tags first calculate neg ;
+
+: calc-arith ( string -- n )
+ string>xml first-child-tag calculate ;
+
+[ 32 ] [
+ "<math><times><add><number>1</number><number>3</number></add><neg><number>-8</number></neg></times></math>"
+ calc-arith
+] unit-test
--- /dev/null
+! Copyright (C) 2005, 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: words assocs kernel accessors parser sequences summary
+lexer splitting fry ;
+IN: xml.dispatch
+
+TUPLE: process-missing process tag ;
+M: process-missing summary
+ drop "Tag not implemented on process" ;
+
+: run-process ( tag word -- )
+ 2dup "xtable" word-prop
+ [ dup main>> ] dip at* [ 2nip call ] [
+ drop \ process-missing boa throw
+ ] if ;
+
+: PROCESS:
+ CREATE
+ dup H{ } clone "xtable" set-word-prop
+ dup '[ _ run-process ] define ; parsing
+
+: TAG:
+ scan scan-word
+ parse-definition
+ swap "xtable" word-prop
+ rot "/" split [ [ 2dup ] dip swap set-at ] each 2drop ;
+ parsing
[ 3 f URL" http://factorcode.org/" "hello" \ drop
<XML <x number=<-> false=<-> url=<-> string=<-> word=<->/> XML>
pprint-xml>string ] unit-test
+
+[ "<x>3</x>" ] [ 3 [XML <x><-></x> XML] xml-chunk>string ] unit-test
+[ "<x></x>" ] [ f [XML <x><-></x> XML] xml-chunk>string ] unit-test
M: object push-item present , ;
M: sequence push-item
[ dup array? [ % ] [ , ] if ] each ;
+M: number push-item present , ;
GENERIC: interpolate-item ( table item -- )
M: object interpolate-item nip , ;
ABOUT: "xml.utilities"
ARTICLE: "xml.utilities" "Utilities for processing XML"
- "Utilities for processing XML include..."
- $nl
- "System sfor creating words which dispatch on XML tags:"
- { $subsection POSTPONE: PROCESS: }
- { $subsection POSTPONE: TAG: }
"Getting parts of an XML document or tag:"
$nl
"Note: the difference between deep-tag-named and tag-named is that the former searches recursively among all children and children of children of the tag, while the latter only looks at the direct children, and is therefore more efficient."
{ $subsection deep-tag-named }
{ $subsection deep-tags-named }
{ $subsection get-id }
- "Words for simplified generation of XML:"
- { $subsection build-tag* }
- { $subsection build-tag }
- { $subsection build-xml }
- "Other relevant words:"
+ "To get at the contents of a single tag, use"
{ $subsection children>string }
{ $subsection children-tags }
{ $subsection first-child-tag }
HELP: deep-tag-named
{ $values { "tag" "an XML tag or document" } { "name/string" "an XML name or string representing a name" } { "matching-tag" tag } }
-{ $description "finds an XML tag with a matching name, recursively searching children and children of children" }
+{ $description "Finds an XML tag with a matching name, recursively searching children and children of children." }
{ $see-also tags-named tag-named deep-tags-named } ;
HELP: deep-tags-named
{ $values { "tag" "an XML tag or document" } { "name/string" "an XML name or string representing a name" } { "tags-seq" "a sequence of tags" } }
-{ $description "returns a sequence of all tags of a matching name, recursively searching children and children of children" }
+{ $description "Returns a sequence of all tags of a matching name, recursively searching children and children of children." }
{ $see-also tag-named deep-tag-named tags-named } ;
HELP: children>string
{ $values { "tag" "an XML tag or document" } { "string" "a string" } }
-{ $description "concatenates the children of the tag, ignoring everything that's not a string" } ;
+{ $description "Concatenates the children of the tag, throwing an exception when there is a non-string child." } ;
HELP: children-tags
{ $values { "tag" "an XML tag or document" } { "sequence" sequence } }
-{ $description "gets the children of the tag that are themselves tags" }
+{ $description "Gets the children of the tag that are themselves tags." }
{ $see-also first-child-tag } ;
HELP: first-child-tag
{ $values { "tag" "an XML tag or document" } { "tag" tag } }
-{ $description "returns the first child of the given tag that is a tag" }
+{ $description "Returns the first child of the given tag that is a tag." }
{ $see-also children-tags } ;
HELP: tag-named
{ $values { "tag" "an XML tag or document" }
{ "name/string" "an XML name or string representing the name" }
{ "matching-tag" tag } }
-{ $description "finds the first tag with matching name which is the direct child of the given tag" }
+{ $description "Finds the first tag with matching name which is the direct child of the given tag." }
{ $see-also deep-tags-named deep-tag-named tags-named } ;
HELP: tags-named
{ $values { "tag" "an XML tag or document" }
{ "name/string" "an XML name or string representing the name" }
{ "tags-seq" "a sequence of tags" } }
-{ $description "finds all tags with matching name that are the direct children of the given tag" }
+{ $description "Finds all tags with matching name that are the direct children of the given tag." }
{ $see-also deep-tag-named deep-tags-named tag-named } ;
HELP: get-id
{ $values { "tag" "an XML tag or document" } { "id" "a string" } { "elem" "an XML element or f" } }
-{ $description "finds the XML tag with the specified id, ignoring the namespace" } ;
-
-HELP: PROCESS:
-{ $syntax "PROCESS: word" }
-{ $values { "word" "a new word to define" } }
-{ $description "creates a new word to process XML tags" }
-{ $see-also POSTPONE: TAG: } ;
-
-HELP: TAG:
-{ $syntax "TAG: tag word definition... ;" }
-{ $values { "tag" "an xml tag name" } { "word" "an XML process" } }
-{ $description "defines what a process should do when it encounters a specific tag" }
-{ $examples { $code "PROCESS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } }
-{ $see-also POSTPONE: PROCESS: } ;
-
-HELP: build-tag*
-{ $values { "items" "sequence of elements" } { "name" "string" }
- { "tag" tag } }
-{ $description "builds a " { $link tag } " with the specified name, in the namespace \"\" and URL \"\" containing the children listed in item" }
-{ $see-also build-tag build-xml } ;
-
-HELP: build-tag
-{ $values { "item" "an element" } { "name" string } { "tag" tag } }
-{ $description "builds a " { $link tag } " with the specified name containing the single child item" }
-{ $see-also build-tag* build-xml } ;
-
-HELP: build-xml
-{ $values { "tag" tag } { "xml" "an XML document" } }
-{ $description "builds an XML document out of a tag" }
-{ $see-also build-tag* build-tag } ;
+{ $description "Finds the XML tag with the specified id, ignoring the namespace." } ;
+! Copyright (C) 2005, 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: xml xml.utilities tools.test xml.data ;
IN: xml.utilities.tests
-USING: xml xml.utilities tools.test ;
[ "bar" ] [ "<foo>bar</foo>" string>xml children>string ] unit-test
[ "" ] [ "<foo></foo>" string>xml children>string ] unit-test
[ "" ] [ "<foo/>" string>xml children>string ] unit-test
+
+XML-NS: foo http://blah.com
+
+[ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test
-! Copyright (C) 2005, 2006 Daniel Ehrenberg
+! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces sequences words io assocs
quotations strings parser lexer arrays xml.data xml.writer debugger
-splitting vectors sequences.deep combinators fry ;
+splitting vectors sequences.deep combinators fry memoize ;
IN: xml.utilities
-! * System for words specialized on tag names
-
-TUPLE: process-missing process tag ;
-M: process-missing error.
- "Tag <" write
- dup tag>> print-name
- "> not implemented on process process " write
- name>> print ;
-
-: run-process ( tag word -- )
- 2dup "xtable" word-prop
- [ dup main>> ] dip at* [ 2nip call ] [
- drop \ process-missing boa throw
- ] if ;
-
-: PROCESS:
- CREATE
- dup H{ } clone "xtable" set-word-prop
- dup '[ _ run-process ] define ; parsing
-
-: TAG:
- scan scan-word
- parse-definition
- swap "xtable" word-prop
- rot "/" split [ [ 2dup ] dip swap set-at ] each 2drop ;
- parsing
-
-
-! * Common utility functions
-
-: build-tag* ( items name -- tag )
- assure-name swap f swap <tag> ;
-
-: build-tag ( item name -- tag )
- [ 1array ] dip build-tag* ;
-
-: standard-prolog ( -- prolog )
- T{ prolog f "1.0" "UTF-8" f } ;
-
-: build-xml ( tag -- xml )
- standard-prolog { } rot { } <xml> ;
-
: children>string ( tag -- string )
children>> {
{ [ dup empty? ] [ drop "" ] }
: insert-child ( child tag -- )
[ 1vector ] dip insert-children ;
+
+: XML-NS:
+ CREATE-WORD (( string -- name )) over set-stack-effect
+ scan '[ f swap _ <name> ] define-memoized ; parsing
"The " { $vocab-link "xml" } " vocabulary implements the XML 1.0 and 1.1 standards, converting strings of text into XML and vice versa."\r
{ $subsection { "xml" "reading" } }\r
{ $subsection { "xml" "events" } }\r
- { $vocab-subsection "Utilities for processing XML" "xml.utilities" }\r
{ $vocab-subsection "Writing XML" "xml.writer" }\r
{ $vocab-subsection "XML parsing errors" "xml.errors" }\r
{ $vocab-subsection "XML entities" "xml.entities" }\r
- { $vocab-subsection "XML data types" "xml.data" } ;\r
+ { $vocab-subsection "XML data types" "xml.data" }\r
+ { $vocab-subsection "Utilities for processing XML" "xml.utilities" }\r
+ { $vocab-subsection "Dispatch on XML tag names" "xml.dispatch" } ;\r
\r
ABOUT: "xml"\r
projects / factor.git / commitdiff