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