core/io/encodings/encodings.factor

   1 ! Copyright (C) 2008 Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: math kernel sequences sbufs vectors namespaces growable
   4 strings io classes continuations destructors combinators
   5 io.streams.plain splitting byte-arrays
   6 sequences.private accessors ;
   7 IN: io.encodings
   8
   9 ! The encoding descriptor protocol
  10
  11 GENERIC: decode-char ( stream encoding -- char/f )
  12
  13 GENERIC: encode-char ( char stream encoding -- )
  14
  15 GENERIC: <decoder> ( stream encoding -- newstream )
  16
  17 : replacement-char HEX: fffd ; inline
  18
  19 TUPLE: decoder stream code cr ;
  20
  21 ERROR: decode-error ;
  22
  23 GENERIC: <encoder> ( stream encoding -- newstream )
  24
  25 TUPLE: encoder stream code ;
  26
  27 ERROR: encode-error ;
  28
  29 ! Decoding
  30
  31 M: object <decoder> f decoder boa ;
  32
  33 <PRIVATE
  34
  35 : cr+ t >>cr drop ; inline
  36
  37 : cr- f >>cr drop ; inline
  38
  39 : >decoder< ( decoder -- stream encoding )
  40     [ stream>> ] [ code>> ] bi ; inline
  41
  42 : fix-read1 ( stream char -- char )
  43     over cr>> [
  44         over cr-
  45         dup CHAR: \n = [
  46             drop dup stream-read1
  47         ] when
  48     ] when nip ; inline
  49
  50 M: decoder stream-read1
  51     dup >decoder< decode-char fix-read1 ;
  52
  53 : fix-read ( stream string -- string )
  54     over cr>> [
  55         over cr-
  56         "\n" ?head [
  57             over stream-read1 [ suffix ] when*
  58         ] when
  59     ] when nip ; inline
  60
  61 : (read) ( n quot -- n string )
  62     over 0 <string> [
  63         [
  64             slip over
  65             [ swapd set-nth-unsafe f ] [ 3drop t ] if
  66         ] 2curry find-integer
  67     ] keep ; inline
  68
  69 : finish-read ( n string -- string/f )
  70     {
  71         { [ over 0 = ] [ 2drop f ] }
  72         { [ over not ] [ nip ] }
  73         [ swap head ]
  74     } cond ; inline
  75
  76 M: decoder stream-read
  77     tuck >decoder< [ decode-char ] 2curry (read) finish-read fix-read ;
  78
  79 M: decoder stream-read-partial stream-read ;
  80
  81 : line-ends/eof ( stream str -- str ) f like swap cr- ; inline
  82
  83 : line-ends\r ( stream str -- str ) swap cr+ ; inline
  84
  85 : line-ends\n ( stream str -- str )
  86     over cr>> over empty? and
  87     [ drop dup cr- stream-readln ] [ swap cr- ] if ; inline
  88
  89 : handle-readln ( stream str ch -- str )
  90     {
  91         { f [ line-ends/eof ] }
  92         { CHAR: \r [ line-ends\r ] }
  93         { CHAR: \n [ line-ends\n ] }
  94     } case ; inline
  95
  96 : ((read-until)) ( buf quot: ( -- char stop? ) -- string/f sep/f )
  97     dup call
  98     [ >r drop "" like r> ]
  99     [ pick push ((read-until)) ] if ; inline recursive
 100
 101 : (read-until) ( quot -- string/f sep/f )
 102     100 <sbuf> swap ((read-until)) ; inline
 103
 104 : decoder-read-until ( seps stream encoding -- string/f sep/f )
 105     [ decode-char dup [ dup rot member? ] [ 2drop f t ] if ] 3curry
 106     (read-until) ;
 107
 108 M: decoder stream-read-until >decoder< decoder-read-until ;
 109
 110 : decoder-readln ( stream encoding -- string/f sep/f )
 111     [ decode-char dup [ dup "\r\n" member? ] [ drop f t ] if ] 2curry
 112     (read-until) ;
 113
 114 M: decoder stream-readln dup >decoder< decoder-readln handle-readln ;
 115
 116 M: decoder dispose stream>> dispose ;
 117
 118 ! Encoding
 119 M: object <encoder> encoder boa ;
 120
 121 : >encoder< ( encoder -- stream encoding )
 122     [ stream>> ] [ code>> ] bi ; inline
 123
 124 M: encoder stream-write1
 125     >encoder< encode-char ;
 126
 127 : decoder-write ( string stream encoding -- )
 128     [ encode-char ] 2curry each ;
 129
 130 M: encoder stream-write
 131     >encoder< decoder-write ;
 132
 133 M: encoder dispose stream>> dispose ;
 134
 135 M: encoder stream-flush stream>> stream-flush ;
 136
 137 INSTANCE: encoder plain-writer
 138 PRIVATE>
 139
 140 GENERIC# re-encode 1 ( stream encoding -- newstream )
 141
 142 M: object re-encode <encoder> ;
 143
 144 M: encoder re-encode [ stream>> ] dip re-encode ;
 145
 146 : encode-output ( encoding -- )
 147     output-stream [ swap re-encode ] change ;
 148
 149 : with-encoded-output ( encoding quot -- )
 150     [ [ output-stream get ] dip re-encode ] dip
 151     with-output-stream* ; inline
 152
 153 GENERIC# re-decode 1 ( stream encoding -- newstream )
 154
 155 M: object re-decode <decoder> ;
 156
 157 M: decoder re-decode [ stream>> ] dip re-decode ;
 158
 159 : decode-input ( encoding -- )
 160     input-stream [ swap re-decode ] change ;
 161
 162 : with-decoded-input ( encoding quot -- )
 163     [ [ input-stream get ] dip re-decode ] dip
 164     with-input-stream* ; inline