basis/io/encodings/iso2022/iso2022.factor

   1 ! Copyright (C) 2009 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs biassocs byte-arrays combinators
   4 combinators.short-circuit endian io io.encodings kernel
   5 literals math math.bitwise namespaces sequences simple-flat-file ;
   6 IN: io.encodings.iso2022
   7
   8 SINGLETON: iso2022
   9
  10 <PRIVATE
  11
  12 SYMBOL: jis201
  13 SYMBOL: jis208
  14 SYMBOL: jis212
  15
  16 "vocab:io/encodings/iso2022/201.txt" load-codetable-file jis201 set-global
  17 "vocab:io/encodings/iso2022/208.txt" load-codetable-file jis208 set-global
  18 "vocab:io/encodings/iso2022/212.txt" load-codetable-file jis212 set-global
  19
  20 SYMBOL: ascii
  21 128 <iota> dup zip >biassoc ascii set-global
  22
  23 TUPLE: iso2022-state type ;
  24
  25 : make-iso-coder ( encoding -- state )
  26     drop ascii get-global iso2022-state boa ;
  27
  28 M: iso2022 <encoder>
  29     make-iso-coder <encoder> ;
  30
  31 M: iso2022 <decoder>
  32     make-iso-coder <decoder> ;
  33
  34 CONSTANT: ESC 0x16
  35
  36 CONSTANT: switch-ascii B{ $ ESC CHAR: ( CHAR: B }
  37 CONSTANT: switch-jis201 B{ $ ESC CHAR: ( CHAR: J }
  38 CONSTANT: switch-jis208 B{ $ ESC CHAR: $ CHAR: B }
  39 CONSTANT: switch-jis212 B{ $ ESC CHAR: $ CHAR: ( CHAR: D }
  40
  41 : find-type ( char -- code type )
  42     {
  43         { [ dup ascii get-global value? ] [ drop switch-ascii ascii get-global ] }
  44         { [ dup jis201 get-global value? ] [ drop switch-jis201 jis201 get-global ] }
  45         { [ dup jis208 get-global value? ] [ drop switch-jis208 jis208 get-global ] }
  46         { [ dup jis212 get-global value? ] [ drop switch-jis212 jis212 get-global ] }
  47         [ encode-error ]
  48     } cond ;
  49
  50 : stream-write-num ( num stream -- )
  51     over 256 >=
  52     [ [ h>b/b swap 2byte-array ] dip stream-write ]
  53     [ stream-write1 ] if ;
  54
  55 M:: iso2022-state encode-char ( char stream encoding -- )
  56     char encoding type>> value? [
  57         char find-type
  58         [ stream stream-write ]
  59         [ encoding type<< ] bi*
  60     ] unless
  61     char encoding type>> value-at stream stream-write-num ;
  62
  63 : read-escape ( stream -- type/f )
  64     dup stream-read1 {
  65         { CHAR: ( [
  66             stream-read1 {
  67                 { CHAR: B [ ascii get-global ] }
  68                 { CHAR: J [ jis201 get-global ] }
  69                 [ drop f ]
  70             } case
  71         ] }
  72         { CHAR: $ [
  73             dup stream-read1 {
  74                 { CHAR: @ [ drop jis208 get-global ] } ! want: JIS X 0208-1978
  75                 { CHAR: B [ drop jis208 get-global ] }
  76                 { CHAR: ( [
  77                     stream-read1 CHAR: D = jis212 get-global f ?
  78                 ] }
  79                 [ 2drop f ]
  80             } case
  81         ] }
  82         [ 2drop f ]
  83     } case ;
  84
  85 : double-width? ( type -- ? )
  86     { [ jis208 get-global eq? ] [ jis212 get-global eq? ] } 1|| ;
  87
  88 : finish-decode ( num encoding -- char )
  89     type>> at replacement-char or ;
  90
  91 M:: iso2022-state decode-char ( stream encoding -- char )
  92     stream stream-read1 {
  93         { $ ESC [
  94             stream read-escape [
  95                 encoding type<<
  96                 stream encoding decode-char
  97             ] [ replacement-char ] if*
  98         ] }
  99         { f [ f ] }
 100         [
 101             encoding type>> double-width? [
 102                 stream stream-read1
 103                 [ 2byte-array be> encoding finish-decode ]
 104                 [ drop replacement-char ] if*
 105             ] [ encoding finish-decode ] if
 106         ]
 107     } case ;
 108
 109 PRIVATE>