basis/io/encodings/utf16/utf16.factor

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