core/io/encodings/utf16/utf16.factor

   1 ! Copyright (C) 2006, 2008 Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: math kernel sequences sbufs vectors namespaces io.binary
   4 io.encodings combinators splitting io byte-arrays ;
   5 IN: io.encodings.utf16
   6
   7 SYMBOL: double
   8 SYMBOL: quad1
   9 SYMBOL: quad2
  10 SYMBOL: quad3
  11 SYMBOL: ignore
  12
  13 : do-ignore ( -- ch state ) 0 ignore ;
  14
  15 : append-nums ( byte ch -- ch )
  16     8 shift bitor ;
  17
  18 : end-multibyte ( buf byte ch -- buf ch state )
  19     append-nums push-decoded ;
  20
  21 : begin-utf16be ( buf byte -- buf ch state )
  22     dup -3 shift BIN: 11011 number= [
  23         dup BIN: 00000100 bitand zero?
  24         [ BIN: 11 bitand quad1 ]
  25         [ drop do-ignore ] if
  26     ] [ double ] if ;
  27
  28 : handle-quad2be ( byte ch -- ch state )
  29     swap dup -2 shift BIN: 110111 number= [
  30         >r 2 shift r> BIN: 11 bitand bitor quad3
  31     ] [ 2drop do-ignore ] if ;
  32
  33 : decode-utf16be-step ( buf byte ch state -- buf ch state )
  34     {
  35         { begin [ drop begin-utf16be ] }
  36         { double [ end-multibyte ] }
  37         { quad1 [ append-nums quad2 ] }
  38         { quad2 [ handle-quad2be ] }
  39         { quad3 [ append-nums HEX: 10000 + push-decoded ] }
  40         { ignore [ 2drop push-replacement ] }
  41     } case ;
  42
  43 : decode-utf16be ( seq -- str )
  44     [ decode-utf16be-step ] decode ;
  45
  46 : handle-double ( buf byte ch -- buf ch state )
  47     swap dup -3 shift BIN: 11011 = [
  48         dup BIN: 100 bitand 0 number=
  49         [ BIN: 11 bitand 8 shift bitor quad2 ]
  50         [ 2drop push-replacement ] if
  51     ] [ end-multibyte ] if ;
  52
  53 : handle-quad3le ( buf byte ch -- buf ch state )
  54     swap dup -2 shift BIN: 110111 = [
  55         BIN: 11 bitand append-nums HEX: 10000 + push-decoded
  56     ] [ 2drop push-replacement ] if ;
  57
  58 : decode-utf16le-step ( buf byte ch state -- buf ch state )
  59     {
  60         { begin [ drop double ] }
  61         { double [ handle-double ] }
  62         { quad1 [ append-nums quad2 ] }
  63         { quad2 [ 10 shift bitor quad3 ] }
  64         { quad3 [ handle-quad3le ] }
  65     } case ;
  66
  67 : decode-utf16le ( seq -- str )
  68     [ decode-utf16le-step ] decode ;
  69
  70 : encode-first
  71     -10 shift
  72     dup -8 shift BIN: 11011000 bitor
  73     swap HEX: FF bitand ;
  74
  75 : encode-second
  76     BIN: 1111111111 bitand
  77     dup -8 shift BIN: 11011100 bitor
  78     swap BIN: 11111111 bitand ;
  79
  80 : char>utf16be ( char -- )
  81     dup HEX: FFFF > [
  82         HEX: 10000 -
  83         dup encode-first swap , ,
  84         encode-second swap , ,
  85     ] [ h>b/b , , ] if ;
  86
  87 : encode-utf16be ( str -- seq )
  88     [ [ char>utf16be ] each ] B{ } make ;
  89
  90 : char>utf16le ( char -- )
  91     dup HEX: FFFF > [
  92         HEX: 10000 -
  93         dup encode-first , ,
  94         encode-second , ,
  95     ] [ h>b/b swap , , ] if ;
  96
  97 : encode-utf16le ( str -- seq )
  98     [ [ char>utf16le ] each ] B{ } make ;
  99
 100 : bom-le B{ HEX: ff HEX: fe } ; inline
 101
 102 : bom-be B{ HEX: fe HEX: ff } ; inline
 103
 104 : encode-utf16 ( str -- seq )
 105     encode-utf16le bom-le swap append ;
 106
 107 : start-utf16le? ( seq1 -- seq2 ? ) bom-le ?head ;
 108
 109 : start-utf16be? ( seq1 -- seq2 ? ) bom-be ?head ;
 110
 111 : decode-utf16 ( seq -- str )
 112     {
 113         { [ start-utf16le? ] [ decode-utf16le ] }
 114         { [ start-utf16be? ] [ decode-utf16be ] }
 115         { [ t ] [ decode-error ] }
 116     } cond ;
 117
 118 TUPLE: utf16le ;
 119
 120 M: utf16le encode-string drop encode-utf16le ;
 121 M: utf16le decode-step drop decode-utf16le-step ;
 122
 123 TUPLE: utf16be ;
 124
 125 M: utf16be encode-string drop encode-utf16be ;
 126 M: utf16be decode-step drop decode-utf16be-step ;
 127
 128 TUPLE: utf16 encoding ;
 129 M: utf16 underlying-stream delegate dup delegate [ ] [ ] ?if ; ! necessary?
 130 M: utf16 set-underlying-stream delegate set-delegate ; ! necessary?
 131
 132 M: utf16 encode-string
 133     >r encode-utf16le r>
 134     dup utf16-encoding [ drop ]
 135     [ t swap set-utf16-encoding bom-le swap append ] if ;
 136
 137 : bom>le/be ( bom -- le/be )
 138     dup bom-le sequence= [ drop utf16le ] [
 139         bom-be sequence= [ utf16be ] [ decode-error ] if
 140     ] if ;
 141
 142 : read-bom ( utf16 -- encoding )
 143     2 over delegate stream-read bom>le/be construct-empty
 144     [ swap set-utf16-encoding ] keep ;
 145
 146 M: utf16 decode-step
 147     ! inefficient: checks if bom is done many times
 148     ! This should transform itself into utf16be or utf16le after reading BOM
 149     dup utf16-encoding [ ] [ read-bom ] ?if decode-step ;