basis/xml/autoencoding/autoencoding.factor

   1 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel namespaces xml.name io.encodings.utf8 xml.elements
   4 io.encodings.utf16 xml.tokenize xml.state math ascii sequences
   5 io.encodings.string io.encodings combinators accessors
   6 xml.data io.encodings.iana xml.errors ;
   7 IN: xml.autoencoding
   8
   9 : decode-stream ( encoding -- )
  10     spot get [ swap re-decode ] change-stream drop ;
  11
  12 : continue-make-tag ( str -- tag )
  13     parse-name-starting middle-tag end-tag ;
  14
  15 : start-utf16le ( -- tag )
  16     utf16le decode-stream
  17     "?\0" expect
  18     check instruct ;
  19
  20 : 10xxxxxx? ( ch -- ? )
  21     -6 shift 3 bitand 2 = ;
  22
  23 : start<name ( ch -- tag )
  24     ! This is unfortunate, and exists for the corner case
  25     ! that the first letter of the document is < and second is
  26     ! not ASCII
  27     ascii?
  28     [ utf8 decode-stream next make-tag ] [
  29         next
  30         [ drop get-next 10xxxxxx? not ] take-until
  31         get-char suffix utf8 decode
  32         utf8 decode-stream next
  33         continue-make-tag
  34     ] if ;
  35
  36 : prolog-encoding ( prolog -- )
  37     encoding>> dup "UTF-16" =
  38     [ drop ] [
  39         dup name>encoding
  40         [ decode-stream ] [ bad-encoding ] ?if
  41     ] if ;
  42
  43 : instruct-encoding ( instruct/prolog -- )
  44     dup prolog?
  45     [ prolog-encoding ]
  46     [ drop utf8 decode-stream ] if ;
  47
  48 : go-utf8 ( -- )
  49     check utf8 decode-stream next next ;
  50
  51 : start< ( -- tag )
  52     ! What if first letter of processing instruction is non-ASCII?
  53     get-next {
  54         { 0 [ next next start-utf16le ] }
  55         { CHAR: ? [ go-utf8 instruct dup instruct-encoding ] }
  56         { CHAR: ! [ go-utf8 direct ] }
  57         [ check start<name ]
  58     } case ;
  59
  60 : skip-utf8-bom ( -- tag )
  61     "\u0000bb\u0000bf" expect utf8 decode-stream
  62     "<" expect check make-tag ;
  63
  64 : decode-expecting ( encoding string -- tag )
  65     [ decode-stream next ] [ expect ] bi* check make-tag ;
  66
  67 : start-utf16be ( -- tag )
  68     utf16be "<" decode-expecting ;
  69
  70 : skip-utf16le-bom ( -- tag )
  71     utf16le "\u0000fe<" decode-expecting ;
  72
  73 : skip-utf16be-bom ( -- tag )
  74     utf16be "\u0000ff<" decode-expecting ;
  75
  76 : start-document ( -- tag )
  77     get-char {
  78         { CHAR: < [ start< ] }
  79         { 0 [ start-utf16be ] }
  80         { 0xEF [ skip-utf8-bom ] }
  81         { 0xFF [ skip-utf16le-bom ] }
  82         { 0xFE [ skip-utf16be-bom ] }
  83         [ drop utf8 decode-stream check f ]
  84     } case ;
  85