extra/binhex/binhex.factor

   1 ! Copyright (C) 2022 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors base64.private byte-arrays combinators endian
   5 grouping io io.encodings.binary io.encodings.string
   6 io.encodings.utf8 io.files io.streams.byte-array kernel
   7 kernel.private literals make math math.bitwise sequences
   8 splitting.monotonic ;
   9
  10 IN: binhex
  11
  12 TUPLE: binhex name type auth flags data resource ;
  13
  14 <PRIVATE
  15
  16 : rel90, ( ch -- )
  17     [ , ] [ 0x90 = [ 0x00 , ] when ] bi ;
  18
  19 : rel90% ( slice -- )
  20     [ first ] [ length 255 /mod ] bi
  21     [ [ dup rel90, 0x90 , 0xff , ] times rel90, ]
  22     [ dup 1 > [ 0x90 , , ] [ drop ] if ] bi* ;
  23
  24 : rle90-encode ( bytes -- bytes' )
  25     [ [ = ] monotonic-split-slice [ rel90% ] each ] B{ } make ;
  26
  27 : rle90-decode ( bytes -- bytes' )
  28     binary [
  29         [
  30             0 [
  31                 read1 [
  32                     dup 0x90 = [
  33                         drop read1 dup 0x00 =
  34                         [ 2drop 0x90 dup , ]
  35                         [ 1 - over <repetition> % ] if
  36                     ] [
  37                         nip dup [ , ] when*
  38                     ] if
  39                 ] keep
  40             ] loop drop
  41         ] B{ } make
  42     ] with-byte-reader ;
  43
  44 <<
  45 CONSTANT: alphabet $[
  46     "!\"#$%&'()*+,-012345689@ABCDEFGHIJKLMNPQRSTUVXYZ[`abcdefhijklmpqr"
  47     >byte-array
  48 ]
  49 >>
  50
  51 ERROR: malformed-hqx ;
  52
  53 : ch>hqx ( ch -- ch )
  54     alphabet nth ; inline
  55
  56 : hqx>ch ( ch -- ch )
  57     $[ alphabet alphabet-inverse ] nth
  58     [ malformed-hqx ] unless* { fixnum } declare ; inline
  59
  60 : hqx-decode ( chars -- bytes )
  61     [
  62         [ 0 0 ] dip [
  63             dup "\r\n\t\s" member? [ drop ] [
  64                 hqx>ch swap {
  65                     { 0 [ nip 6 ] }
  66                     { 2 [ [ 6 shift ] dip + , 0 0 ] }
  67                     { 4 [ [ 4 shift ] dip [ -2 shift + , ] [ 2 bits ] bi 2 ] }
  68                     { 6 [ [ 2 shift ] dip [ -4 shift + , ] [ 4 bits ] bi 4 ] }
  69                 } case
  70             ] if
  71         ] each 2drop
  72     ] B{ } make ;
  73
  74 : hqx-encode ( bytes -- chars )
  75     [
  76         [ 0 0 ] dip [
  77             swap {
  78                 { 0 [ nip [ -2 shift ch>hqx , ] [ 2 bits ] bi 2 ] }
  79                 { 2 [ [ 4 shift ] dip [ -4 shift + ch>hqx , ] [ 4 bits ] bi 4 ] }
  80                 { 4 [ [ 2 shift ] dip [ -6 shift + ch>hqx , ] [ 6 bits ] bi 6 ] }
  81                 { 6 [ [ ch>hqx , ] dip [ -2 shift ch>hqx , ] [ 2 bits ] bi 2 ] }
  82             } case
  83         ] each 6 swap - shift ch>hqx ,
  84     ] B{ } make ;
  85
  86 : crc16-binhex ( bytes -- n )
  87     0 [| b |
  88         8 <iota> [| i |
  89             dup 15 bit?
  90             [
  91                 2 * 0xffff bitand
  92                 b 7 i - bit? [ 1 + ] when
  93             ]
  94             [ [ 0x1021 bitxor ] when ] bi*
  95         ] each
  96     ] reduce
  97     16 [
  98         dup 15 bit?
  99         [ 2 * 0xffff bitand ]
 100         [ [ 0x1021 bitxor ] when ] bi*
 101     ] times ;
 102
 103 : check-crc ( bytes -- bytes )
 104     dup crc16-binhex 2 read be> assert= ;
 105
 106 : skip-return ( -- ch )
 107     read1 [ dup "\r\n\t\s" member? ] [ drop read1 ] while ;
 108
 109 :: read-header ( -- name type auth flags #data #resource )
 110     read1 :> n
 111     n 19 + read n prefix check-crc :> header
 112     1 dup n + header subseq utf8 decode
 113     n 2 + dup 4 + header subseq be>
 114     n 6 + dup 4 + header subseq be>
 115     n 10 + dup 2 + header subseq be>
 116     n 12 + dup 4 + header subseq be>
 117     n 16 + dup 4 + header subseq be> ;
 118
 119 PRIVATE>
 120
 121 : read-binhex ( -- binhex )
 122     "\r\n" read-until drop
 123     "(This file must be converted " head? t assert=
 124     skip-return CHAR: : assert=
 125     ":" read-until CHAR: : assert=
 126     hqx-decode rle90-decode
 127     binary [
 128         read-header [ read check-crc ] bi@ binhex boa
 129     ] with-byte-reader ;
 130
 131 : file>binhex ( path -- binhex )
 132     binary [ read-binhex ] with-file-reader ;
 133
 134 <PRIVATE
 135
 136 CONSTANT: begin $[
 137     "(This file must be converted with BinHex 4.0)" >byte-array
 138 ]
 139
 140 : write-with-crc ( bytes -- )
 141     [ write ] [ crc16-binhex 2 >be write ] bi ;
 142
 143 : write-header ( binhex -- )
 144     binary [
 145         {
 146             [ name>> utf8 encode [ length write1 ] [ write ] bi 0 write1 ]
 147             [ type>> 4 >be write ]
 148             [ auth>> 4 >be write ]
 149             [ flags>> 2 >be write ]
 150             [ data>> length 4 >be write ]
 151             [ resource>> length 4 >be write ]
 152         } cleave
 153     ] with-byte-writer write-with-crc ;
 154
 155 PRIVATE>
 156
 157 : write-binhex ( binhex -- )
 158     begin write
 159     CHAR: \r write1
 160     CHAR: \r write1
 161     CHAR: : write1
 162     binary [
 163         [ write-header ] [ data>> ] [ resource>> ] tri
 164         [ write-with-crc ] bi@
 165     ] with-byte-writer
 166     rle90-encode hqx-encode
 167     64 group [ CHAR: \r write1 ] [ write ] interleave
 168     CHAR: : write1
 169     CHAR: \r write1 ;
 170
 171 : binhex>file ( binhex path -- )
 172     binary [ write-binhex ] with-file-writer ;