core/io/encodings/encodings.factor

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