basis/io/encodings/utf7/utf7.factor

   1 ! Copyright (C) 2013-2014 Björn Lindqvist
   2 ! See http://factorcode.org/license.txt for BSD license
   3 USING: accessors ascii base64 fry io io.encodings
   4 io.encodings.string io.encodings.utf16 kernel make math
   5 math.functions sequences splitting strings ;
   6 IN: io.encodings.utf7
   7
   8 TUPLE: utf7codec dialect buffer ;
   9
  10 ! These words encodes the difference between standard utf7 and the
  11 ! dialect used by IMAP which wants slashes replaced with commas when
  12 ! encoding and uses '&' instead of '+' as the escaping character.
  13 : utf7 ( -- utf7codec )
  14     {
  15         { { } { } }
  16         { { CHAR: + } { CHAR: - } }
  17     } V{ } utf7codec boa ;
  18
  19 : utf7imap4 ( -- utf7codec )
  20     {
  21         { { CHAR: / } { CHAR: , } }
  22         { { CHAR: & } { CHAR: - } }
  23     } V{ } utf7codec boa ;
  24
  25 : >raw-base64 ( bytes -- bytes' )
  26     >string utf16be encode >base64 [ CHAR: = = ] trim-tail ;
  27
  28 : raw-base64> ( str -- str' )
  29     dup length 4 / ceiling 4 * CHAR: = pad-tail base64> utf16be decode ;
  30
  31 : encode-chunk ( repl-pair surround-pair chunk printable? -- bytes )
  32     [ swap [ first ] [ concat ] bi replace nip ]
  33     [ >raw-base64 -rot [ first2 replace ] [ first2 surround ] bi* ] if ;
  34
  35 : split-chunk ( str -- after before printable? )
  36     dup first printable? [
  37         [ 1 over ] dip '[ printable? _ = not ] find-from drop
  38         [ cut-slice ] [ f ] if* swap
  39     ] keep ;
  40
  41 : encode-utf7-string ( str codec -- bytes )
  42     dialect>> first2 rot '[
  43         [ dup empty? ] [
  44             split-chunk '[ 2dup _ _ encode-chunk % ] dip
  45         ] until
  46     ] B{ } make 3nip ;
  47
  48 M: utf7codec encode-string
  49     swapd encode-utf7-string swap stream-write ;
  50
  51 DEFER: emit-char
  52
  53 : decode-chunk ( dialect -- ch buffer )
  54     dup first2 swap [ second read-until drop ] [ first2 swap replace ] bi*
  55     [ second first first { } ] [ raw-base64> emit-char ] if-empty ;
  56
  57 : fill-buffer ( dialect -- ch buffer )
  58     dup second first first read1 dup swapd = [
  59         drop decode-chunk
  60     ] [ nip { } ] if ;
  61
  62 : emit-char ( dialect buffer -- ch buffer' )
  63     [ fill-buffer ] [ nip unclip swap ] if-empty ;
  64
  65 : replace-all! ( src dst -- )
  66     [ delete-all ] keep push-all ;
  67
  68 M: utf7codec decode-char
  69     swap [
  70         [ dialect>> ] [ buffer>> ] bi [ emit-char ] keep replace-all!
  71     ] with-input-stream ;