extra/uu/uu.factor

   1 ! Copyright (C) 2013 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: combinators.short-circuit io io.streams.string kernel
   5 locals make math math.bitwise 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 < ] [ CHAR: \s 64 + > ] } 1||
  44     [ illegal-character ] when ;
  45
  46 :: ascii>binary ( seq -- seq' )
  47     0 :> char!
  48     0 :> bits!
  49
  50     seq unclip-slice dup CHAR: \s =
  51     [ drop 0 ] [ CHAR: \s - ] if :> len!
  52
  53     [
  54         [ dup empty? not len 0 > and ] [
  55             dup empty? [ 0 ] [ unclip-slice ] if
  56             dup "\r\n\0" member? [
  57                 drop 0
  58             ] [
  59                 check-illegal-character
  60                 CHAR: \s -
  61             ] if
  62
  63             char 6 shift bitor char!
  64             bits 6 + bits!
  65
  66             bits 8 >= [
  67                 bits 8 -
  68                 [ char swap neg shift 0xff bitand , ]
  69                 [ on-bits char bitand char! ]
  70                 [ bits! ] tri
  71                 len 1 - len!
  72             ] when
  73         ] while drop
  74
  75     ] "" make ;
  76
  77 PRIVATE>
  78
  79 : uu-encode ( -- )
  80     "begin" print
  81     input-stream get [ binary>ascii print ] 45 (each-stream-block)
  82     "end" print ;
  83
  84 : string>uu ( seq -- seq' )
  85     [ [ uu-encode ] with-string-writer ] with-string-reader ;
  86
  87 : uu-decode ( -- )
  88     [ [ "begin" head? ] [ not ] bi or ] [ readln ] do until
  89     [
  90         dup [ "end" head? ] [ not ] bi or
  91         [ drop t ] [ ascii>binary write f ] if
  92     ] [ readln ] do until ;
  93
  94 : uu>string ( seq -- seq )
  95     [ [ uu-decode ] with-string-writer ] with-string-reader ;