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