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 summary ;
   5 IN: io.encodings.utf16
   6
   7 SINGLETON: utf16be
   8
   9 SINGLETON: utf16le
  10
  11 SINGLETON: utf16
  12
  13 <PRIVATE
  14
  15 ! UTF-16BE decoding
  16
  17 : append-nums ( byte ch -- ch )
  18     over [ 8 shift bitor ] [ 2drop replacement-char ] if ;
  19
  20 : double-be ( stream byte -- stream char )
  21     over stream-read1 swap append-nums ;
  22
  23 : quad-be ( stream byte -- stream char )
  24     double-be over stream-read1 [
  25         dup -2 shift BIN: 110111 number= [
  26             >r 2 shift r> BIN: 11 bitand bitor
  27             over stream-read1 swap append-nums HEX: 10000 +
  28         ] [ 2drop dup stream-read1 drop replacement-char ] if
  29     ] when* ;
  30
  31 : ignore ( stream -- stream char )
  32     dup stream-read1 drop replacement-char ;
  33
  34 : begin-utf16be ( stream byte -- stream char )
  35     dup -3 shift BIN: 11011 number= [
  36         dup BIN: 00000100 bitand zero?
  37         [ BIN: 11 bitand quad-be ]
  38         [ drop ignore ] if
  39     ] [ double-be ] if ;
  40
  41 M: utf16be decode-char
  42     drop dup stream-read1 dup [ begin-utf16be ] when nip ;
  43
  44 ! UTF-16LE decoding
  45
  46 : quad-le ( stream ch -- stream char )
  47     over stream-read1 swap 10 shift bitor
  48     over stream-read1 dup -2 shift BIN: 110111 = [
  49         BIN: 11 bitand append-nums HEX: 10000 +
  50     ] [ 2drop replacement-char ] if ;
  51
  52 : double-le ( stream byte1 byte2 -- stream char )
  53     dup -3 shift BIN: 11011 = [
  54         dup BIN: 100 bitand 0 number=
  55         [ BIN: 11 bitand 8 shift bitor quad-le ]
  56         [ 2drop replacement-char ] if
  57     ] [ append-nums ] if ;
  58
  59 : begin-utf16le ( stream byte -- stream char )
  60     over stream-read1 [ double-le ] [ drop replacement-char ] if* ;
  61
  62 M: utf16le decode-char
  63     drop dup stream-read1 dup [ begin-utf16le ] when nip ;
  64
  65 ! UTF-16LE/BE encoding
  66
  67 : encode-first ( char -- byte1 byte2 )
  68     -10 shift
  69     dup -8 shift BIN: 11011000 bitor
  70     swap HEX: FF bitand ;
  71
  72 : encode-second ( char -- byte3 byte4 )
  73     BIN: 1111111111 bitand
  74     dup -8 shift BIN: 11011100 bitor
  75     swap BIN: 11111111 bitand ;
  76
  77 : stream-write2 ( stream char1 char2 -- )
  78     rot [ stream-write1 ] curry bi@ ;
  79
  80 : char>utf16be ( stream char -- )
  81     dup HEX: FFFF > [
  82         HEX: 10000 -
  83         2dup encode-first stream-write2
  84         encode-second stream-write2
  85     ] [ h>b/b swap stream-write2 ] if ;
  86
  87 M: utf16be encode-char ( char stream encoding -- )
  88     drop swap char>utf16be ;
  89
  90 : char>utf16le ( char stream -- )
  91     dup HEX: FFFF > [
  92         HEX: 10000 -
  93         2dup encode-first swap stream-write2
  94         encode-second swap stream-write2
  95     ] [ h>b/b stream-write2 ] if ;
  96
  97 M: utf16le encode-char ( char stream encoding -- )
  98     drop swap char>utf16le ;
  99
 100 ! UTF-16
 101
 102 : bom-le B{ HEX: ff HEX: fe } ; inline
 103
 104 : bom-be B{ HEX: fe HEX: ff } ; inline
 105
 106 : start-utf16le? ( seq1 -- seq2 ? ) bom-le ?head ;
 107
 108 : start-utf16be? ( seq1 -- seq2 ? ) bom-be ?head ;
 109
 110 TUPLE: missing-bom ;
 111 M: missing-bom summary drop "The BOM for a UTF-16 stream was missing" ;
 112
 113 : bom>le/be ( bom -- le/be )
 114     dup bom-le sequence= [ drop utf16le ] [
 115         bom-be sequence= [ utf16be ] [ missing-bom ] if
 116     ] if ;
 117
 118 M: utf16 <decoder> ( stream utf16 -- decoder )
 119     drop 2 over stream-read bom>le/be <decoder> ;
 120
 121 M: utf16 <encoder> ( stream utf16 -- encoder )
 122     drop bom-le over stream-write utf16le <encoder> ;
 123
 124 PRIVATE>