basis/uu/uu.factor

   1 ! Copyright (C) 2013 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: io io.streams.string kernel locals make math math.bitwise
   5 math.order namespaces sequences ;
   6
   7 IN: uu
   8
   9 <PRIVATE
  10
  11 ERROR: bad-length seq ;
  12
  13 : check-length ( seq -- seq )
  14     dup length 45 > [ bad-length ] when ; inline
  15
  16 :: binary>ascii ( seq -- seq' )
  17     0 :> char!
  18     0 :> bits!
  19     seq check-length [
  20         dup length CHAR: \s + ,
  21
  22         [ dup empty? bits zero? and ] [
  23
  24             char 8 shift char!
  25             bits 8 + bits!
  26
  27             dup empty? [
  28                 unclip-slice char bitor char!
  29             ] unless
  30
  31             [ bits 6 >= ] [
  32                 bits 6 -
  33                 [ char swap neg shift 0x3f bitand CHAR: \s + , ]
  34                 [ bits! ] bi
  35             ] while
  36
  37         ] until drop
  38     ] "" make ;
  39
  40 ERROR: illegal-character ch ;
  41
  42 : check-illegal-character ( ch -- ch )
  43     dup CHAR: \s dup 64 + between? [ illegal-character ] unless ;
  44
  45 :: ascii>binary ( seq -- seq' )
  46     0 :> char!
  47     0 :> bits!
  48
  49     seq unclip-slice CHAR: \s - :> len!
  50
  51     [
  52         [ dup empty? not len 0 > and ] [
  53             dup empty? [ 0 ] [ unclip-slice ] if
  54             dup "\r\n\0" member? [
  55                 drop 0
  56             ] [
  57                 check-illegal-character
  58                 CHAR: \s -
  59             ] if
  60
  61             char 6 shift bitor char!
  62             bits 6 + bits!
  63
  64             bits 8 >= [
  65                 bits 8 -
  66                 [ char swap neg shift 0xff bitand , ]
  67                 [ on-bits char bitand char! ]
  68                 [ bits! ] tri
  69                 len 1 - len!
  70             ] when
  71         ] while drop
  72
  73     ] "" make ;
  74
  75 PRIVATE>
  76
  77 : uu-encode ( -- )
  78     "begin" print
  79     input-stream get [ binary>ascii print ] 45 (each-stream-block)
  80     "end" print ;
  81
  82 : string>uu ( seq -- seq' )
  83     [ [ uu-encode ] with-string-writer ] with-string-reader ;
  84
  85 : uu-decode ( -- )
  86     [ [ "begin" head? ] [ not ] bi or ] [ readln ] do until
  87     [
  88         dup [ "end" head? ] [ not ] bi or
  89         [ drop t ] [ ascii>binary write f ] if
  90     ] [ readln ] do until ;
  91
  92 : uu>string ( seq -- seq )
  93     [ [ uu-decode ] with-string-writer ] with-string-reader ;