basis/io/encodings/iso2022/iso2022.factor

   1 ! Copyright (C) 2009 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: io.encodings kernel sequences io simple-flat-file sets math
   4 combinators.short-circuit io.binary values arrays assocs
   5 locals accessors combinators biassocs byte-arrays parser ;
   6 IN: io.encodings.iso2022
   7
   8 SINGLETON: iso2022
   9
  10 <PRIVATE
  11
  12 VALUE: jis201
  13 VALUE: jis208
  14 VALUE: jis212
  15
  16 "vocab:io/encodings/iso2022/201.txt" flat-file>biassoc \ jis201 set-value
  17 "vocab:io/encodings/iso2022/208.txt" flat-file>biassoc \ jis208 set-value
  18 "vocab:io/encodings/iso2022/212.txt" flat-file>biassoc \ jis212 set-value
  19
  20 VALUE: ascii
  21 128 iota unique >biassoc \ ascii set-value
  22
  23 TUPLE: iso2022-state type ;
  24
  25 : make-iso-coder ( encoding -- state )
  26     drop ascii 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 << SYNTAX: ESC 0x16 suffix! ; >>
  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 value? ] [ drop switch-ascii ascii ] }
  44         { [ dup jis201 value? ] [ drop switch-jis201 jis201 ] }
  45         { [ dup jis208 value? ] [ drop switch-jis208 jis208 ] }
  46         { [ dup jis212 value? ] [ drop switch-jis212 jis212 ] }
  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 ] }
  68                 { CHAR: J [ jis201 ] }
  69                 [ drop f ]
  70             } case
  71         ] }
  72         { CHAR: $ [
  73             dup stream-read1 {
  74                 { CHAR: @ [ drop jis208 ] } ! want: JIS X 0208-1978
  75                 { CHAR: B [ drop jis208 ] }
  76                 { CHAR: ( [
  77                     stream-read1 CHAR: D = jis212 f ?
  78                 ] }
  79                 [ 2drop f ]
  80             } case
  81         ] }
  82         [ 2drop f ]
  83     } case ;
  84
  85 : double-width? ( type -- ? )
  86     { [ jis208 eq? ] [ jis212 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 ;