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: 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: encode-string ( string stream encoding -- )
  16
  17 M: object encode-string [ encode-char ] 2curry each ; inline
  18
  19 GENERIC: <decoder> ( stream encoding -- newstream )
  20
  21 CONSTANT: replacement-char HEX: fffd
  22
  23 TUPLE: decoder stream code cr ;
  24
  25 ERROR: decode-error ;
  26
  27 GENERIC: <encoder> ( stream encoding -- newstream )
  28
  29 TUPLE: encoder stream code ;
  30
  31 ERROR: encode-error ;
  32
  33 ! Decoding
  34
  35 M: object <decoder> f decoder boa ;
  36
  37 <PRIVATE
  38
  39 : cr+ ( stream -- ) t >>cr drop ; inline
  40
  41 : cr- ( stream -- ) f >>cr drop ; inline
  42
  43 : >decoder< ( decoder -- stream encoding )
  44     [ stream>> ] [ code>> ] bi ; inline
  45
  46 : fix-read1 ( stream char -- char )
  47     over cr>> [
  48         over cr-
  49         dup CHAR: \n = [
  50             drop dup stream-read1
  51         ] when
  52     ] when nip ; inline
  53
  54 M: decoder stream-element-type
  55     drop +character+ ;
  56
  57 M: decoder stream-tell stream>> stream-tell ;
  58
  59 M: decoder stream-seek stream>> stream-seek ;
  60
  61 M: decoder stream-read1
  62     dup >decoder< decode-char fix-read1 ;
  63
  64 M: decoder stream-peek1 [ stream-read1 ] with-input-rewind ;
  65 M: decoder stream-peek [ stream-read ] with-input-rewind ;
  66
  67 : fix-read ( stream string -- string )
  68     over cr>> [
  69         over cr-
  70         "\n" ?head [
  71             over stream-read1 [ suffix ] when*
  72         ] when
  73     ] when nip ; inline
  74
  75 : (read) ( n quot -- n string )
  76     over 0 <string> [
  77         [
  78             over [ swapd set-nth-unsafe f ] [ 3drop t ] if
  79         ] curry compose find-integer
  80     ] keep ; inline
  81
  82 : finish-read ( n string -- string/f )
  83     {
  84         { [ over 0 = ] [ 2drop f ] }
  85         { [ over not ] [ nip ] }
  86         [ swap head ]
  87     } cond ; inline
  88
  89 M: decoder stream-read
  90     [ nip ] [ >decoder< [ decode-char ] 2curry (read) finish-read ] 2bi
  91     fix-read ;
  92
  93 M: decoder stream-read-partial stream-read ;
  94
  95 : line-ends/eof ( stream str -- str ) f like swap cr- ; inline
  96
  97 : line-ends\r ( stream str -- str ) swap cr+ ; inline
  98
  99 : line-ends\n ( stream str -- str )
 100     over cr>> over empty? and
 101     [ drop dup cr- stream-readln ] [ swap cr- ] if ; inline
 102
 103 : handle-readln ( stream str ch -- str )
 104     {
 105         { f [ line-ends/eof ] }
 106         { CHAR: \r [ line-ends\r ] }
 107         { CHAR: \n [ line-ends\n ] }
 108     } case ; inline
 109
 110 : ((read-until)) ( buf quot: ( -- char stop? ) -- string/f sep/f )
 111     dup call
 112     [ [ drop "" like ] dip ]
 113     [ pick push ((read-until)) ] if ; inline recursive
 114
 115 : (read-until) ( quot -- string/f sep/f )
 116     100 <sbuf> swap ((read-until)) ; inline
 117
 118 : decoder-read-until ( seps stream encoding -- string/f sep/f )
 119     [ decode-char dup [ dup rot member? ] [ 2drop f t ] if ] 3curry
 120     (read-until) ;
 121
 122 M: decoder stream-read-until >decoder< decoder-read-until ;
 123
 124 : decoder-readln ( stream encoding -- string/f sep/f )
 125     [ decode-char dup [ dup "\r\n" member? ] [ drop f t ] if ] 2curry
 126     (read-until) ;
 127
 128 M: decoder stream-readln dup >decoder< decoder-readln handle-readln ;
 129
 130 M: decoder dispose stream>> dispose ;
 131
 132 ! Encoding
 133 M: object <encoder> encoder boa ;
 134
 135 : >encoder< ( encoder -- stream encoding )
 136     [ stream>> ] [ code>> ] bi ; inline
 137
 138 M: encoder stream-element-type
 139     drop +character+ ;
 140
 141 M: encoder stream-write1
 142     >encoder< encode-char ;
 143
 144 M: encoder stream-write
 145     >encoder< encode-string ;
 146
 147 M: encoder dispose stream>> dispose ;
 148
 149 M: encoder stream-flush stream>> stream-flush ;
 150
 151 INSTANCE: encoder plain-writer
 152 PRIVATE>
 153
 154 GENERIC# re-encode 1 ( stream encoding -- newstream )
 155
 156 M: object re-encode <encoder> ;
 157
 158 M: encoder re-encode [ stream>> ] dip re-encode ;
 159
 160 : encode-output ( encoding -- )
 161     output-stream [ swap re-encode ] change ;
 162
 163 : with-encoded-output ( encoding quot -- )
 164     [ [ output-stream get ] dip re-encode ] dip
 165     with-output-stream* ; inline
 166
 167 GENERIC# re-decode 1 ( stream encoding -- newstream )
 168
 169 M: object re-decode <decoder> ;
 170
 171 M: decoder re-decode [ stream>> ] dip re-decode ;
 172
 173 : decode-input ( encoding -- )
 174     input-stream [ swap re-decode ] change ;
 175
 176 : with-decoded-input ( encoding quot -- )
 177     [ [ input-stream get ] dip re-decode ] dip
 178     with-input-stream* ; inline