basis/xml/tests/test.factor

   1 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: xml.tests
   4 USING: kernel xml tools.test io namespaces make sequences
   5 xml.errors xml.entities.html parser strings xml.data io.files
   6 xml.traversal continuations assocs io.encodings.binary
   7 sequences.deep accessors io.streams.string ;
   8
   9 ! This is insufficient
  10 [ [ drop ] each-element ] must-infer
  11
  12 SYMBOL: xml-file
  13 { } [
  14     "vocab:xml/tests/test.xml"
  15     [ file>xml ] with-html-entities xml-file set
  16 ] unit-test
  17 { t } [
  18     "vocab:xml/tests/test.xml" binary file-contents
  19     [ bytes>xml ] with-html-entities xml-file get =
  20 ] unit-test
  21 { "1.0" } [ xml-file get prolog>> version>> ] unit-test
  22 { f } [ xml-file get prolog>> standalone>> ] unit-test
  23 { "a" } [ xml-file get space>> ] unit-test
  24 { "http://www.hello.com" } [ xml-file get url>> ] unit-test
  25 { "that" } [
  26     xml-file get T{ name f "" "this" "http://d.de" } attr
  27 ] unit-test
  28 { t } [ xml-file get children>> second contained-tag? ] unit-test
  29 [ "<a></b>" string>xml ] [ xml-error? ] must-fail-with
  30 { T{ comment f "This is where the fun begins!" } } [
  31     xml-file get before>> [ comment? ] find nip
  32 ] unit-test
  33 { "xsl stylesheet=\"that-one.xsl\"" } [
  34     xml-file get after>> [ instruction? ] find nip text>>
  35 ] unit-test
  36 { V{ "fa&g" } } [ xml-file get "x" get-id children>> ] unit-test
  37 { "that" } [ xml-file get "this" attr ] unit-test
  38 { "abcd" } [
  39     "<main>a<sub>bc</sub>d<nothing/></main>" string>xml
  40     [ [ dup string? [ % ] [ drop ] if ] deep-each ] "" make
  41 ] unit-test
  42 { "abcd" } [
  43     "<main>a<sub>bc</sub>d<nothing/></main>" string>xml
  44     [ string? ] deep-filter concat
  45 ] unit-test
  46 { "foo" } [
  47     "<a><b id='c'>foo</b><d id='e'/></a>" string>xml
  48     "c" get-id children>string
  49 ] unit-test
  50 { "foo" } [
  51     "<x y='foo'/>" string>xml
  52     dup dup "y" attr "z" set-attr
  53     T{ name { space "blah" } { main "z" } } attr
  54 ] unit-test
  55 [ "<!-- B+, B, or B--->" string>xml ] must-fail
  56 { } [ "<?xml version='1.0'?><!-- declarations for <head> & <body> --><foo/>" string>xml drop ] unit-test
  57
  58 : first-thing ( seq -- elt )
  59     "" swap remove first ;
  60
  61 { T{ element-decl f "br" "EMPTY" } } [ "<!ELEMENT br EMPTY>" string>dtd directives>> first-thing ] unit-test
  62 { T{ element-decl f "p" "(#PCDATA|emph)*" } } [ "<!ELEMENT p (#PCDATA|emph)*>" string>dtd directives>> first-thing ] unit-test
  63 { T{ element-decl f "%name.para;" "%content.para;" } } [ "<!ELEMENT %name.para; %content.para;>" string>dtd directives>> first-thing ] unit-test
  64 { T{ element-decl f "container" "ANY" } } [ "<!ELEMENT container ANY>" string>dtd directives>> first-thing ] unit-test
  65 { T{ doctype-decl f "foo" } } [ "<!DOCTYPE foo>" string>xml-chunk first-thing ] unit-test
  66 { T{ doctype-decl f "foo" } } [ "<!DOCTYPE foo >" string>xml-chunk first-thing ] unit-test
  67 { T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } } [ "<!DOCTYPE foo SYSTEM 'blah.dtd'>" string>xml-chunk first-thing ] unit-test
  68 { T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } } [ "<!DOCTYPE foo   SYSTEM \"blah.dtd\"   >" string>xml-chunk first-thing ] unit-test
  69 { 958 } [ [ "&xi;" string>xml-chunk ] with-html-entities first first ] unit-test
  70 { "x" "<" } [ "<x value='&lt;'/>" string>xml [ name>> main>> ] [ "value" attr ] bi ] unit-test
  71 { "foo" } [ "<!DOCTYPE foo [<!ENTITY bar 'foo'>]><x>&bar;</x>" string>xml children>string ] unit-test
  72 { T{ xml-chunk f V{ "hello" } } } [ "hello" string>xml-chunk ] unit-test
  73 { "1.1" } [ "<?xml version='1.1'?><x/>" string>xml prolog>> version>> ] unit-test
  74 { "ß" } [ "<x>ß</x>" <string-reader> read-xml children>string ] unit-test
  75
  76 ! <pull-xml> tests
  77 ! this tests just checks that pull-event doesn't raise an exception
  78 { } [ "vocab:xml/tests/test.xml" binary [ <pull-xml> pull-event drop ] with-file-reader ] unit-test