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: accessors arrays assocs byte-arrays
   4 combinators.short-circuit endian io io.encodings
   5 io.encodings.iana kernel math.bitwise math.order namespaces
   6 simple-flat-file ;
   7 IN: io.encodings.shift-jis
   8
   9 SINGLETON: shift-jis
  10
  11 shift-jis "Shift_JIS" register-encoding
  12
  13 SINGLETON: windows-31j
  14
  15 windows-31j "Windows-31J" register-encoding
  16
  17 <PRIVATE
  18
  19 SYMBOL: shift-jis-table
  20
  21 M: shift-jis <encoder> drop shift-jis-table get-global <encoder> ;
  22 M: shift-jis <decoder> drop shift-jis-table get-global <decoder> ;
  23
  24 SYMBOL: windows-31j-table
  25
  26 M: windows-31j <encoder> drop windows-31j-table get-global <encoder> ;
  27 M: windows-31j <decoder> drop windows-31j-table get-global <decoder> ;
  28
  29 TUPLE: jis assoc ;
  30
  31 : ch>jis ( ch tuple -- jis ) assoc>> value-at [ encode-error ] unless* ;
  32 : jis>ch ( jis tuple -- string ) assoc>> at replacement-char or ;
  33
  34 : make-jis ( filename -- jis )
  35     load-codetable-file sift-values jis boa ;
  36
  37 "vocab:io/encodings/shift-jis/CP932.txt"
  38 make-jis windows-31j-table set-global
  39
  40 "vocab:io/encodings/shift-jis/sjis-0208-1997-std.txt"
  41 make-jis shift-jis-table set-global
  42
  43 : small? ( char -- ? )
  44     ! ASCII range or single-byte halfwidth katakana
  45     { [ 0 0x7F between? ] [ 0xA1 0xDF between? ] } 1|| ;
  46
  47 : write-halfword ( stream halfword -- )
  48     h>b/b swap 2byte-array swap stream-write ;
  49
  50 M: jis encode-char
  51     swapd ch>jis
  52     dup small?
  53     [ swap stream-write1 ]
  54     [ write-halfword ] if ;
  55
  56 M: jis decode-char
  57     swap dup stream-read1 [
  58         dup small? [ nip swap jis>ch ] [
  59             swap stream-read1
  60             [ 2array be> swap jis>ch ]
  61             [ 2drop replacement-char ] if*
  62         ] if
  63     ] [ 2drop f ] if* ;
  64
  65 PRIVATE>