basis/io/encodings/shift-jis/shift-jis.factor

   1 ! Copyright (C) 2009 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: sequences kernel io io.files combinators.short-circuit
   4 math.order values assocs io.encodings io.binary fry strings math
   5 io.encodings.ascii arrays byte-arrays accessors splitting
   6 math.parser biassocs io.encodings.iana
   7 locals multiline combinators simple-flat-file ;
   8 IN: io.encodings.shift-jis
   9
  10 SINGLETON: shift-jis
  11
  12 shift-jis "Shift_JIS" register-encoding
  13
  14 SINGLETON: windows-31j
  15
  16 windows-31j "Windows-31J" register-encoding
  17
  18 <PRIVATE
  19
  20 VALUE: shift-jis-table
  21
  22 M: shift-jis <encoder> drop shift-jis-table <encoder> ;
  23 M: shift-jis <decoder> drop shift-jis-table <decoder> ;
  24
  25 VALUE: windows-31j-table
  26
  27 M: windows-31j <encoder> drop windows-31j-table <encoder> ;
  28 M: windows-31j <decoder> drop windows-31j-table <decoder> ;
  29
  30 TUPLE: jis assoc ;
  31
  32 : ch>jis ( ch tuple -- jis ) assoc>> value-at [ encode-error ] unless* ;
  33 : jis>ch ( jis tuple -- string ) assoc>> at replacement-char or ;
  34
  35 : make-jis ( filename -- jis )
  36     flat-file>biassoc [ nip ] assoc-filter jis boa ;
  37
  38 "vocab:io/encodings/shift-jis/CP932.txt"
  39 make-jis \ windows-31j-table set-value
  40
  41 "vocab:io/encodings/shift-jis/sjis-0208-1997-std.txt"
  42 make-jis \ shift-jis-table set-value
  43
  44 : small? ( char -- ? )
  45     ! ASCII range or single-byte halfwidth katakana
  46     { [ 0 0x7F between? ] [ 0xA1 0xDF between? ] } 1|| ;
  47
  48 : write-halfword ( stream halfword -- )
  49     h>b/b swap 2byte-array swap stream-write ;
  50
  51 M: jis encode-char
  52     swapd ch>jis
  53     dup small?
  54     [ swap stream-write1 ]
  55     [ write-halfword ] if ;
  56
  57 M: jis decode-char
  58     swap dup stream-read1 [
  59         dup small? [ nip swap jis>ch ] [
  60             swap stream-read1
  61             [ 2array be> swap jis>ch ]
  62             [ 2drop replacement-char ] if*
  63         ] if
  64     ] [ 2drop f ] if* ;