1 ! Copyright (C) 2022 John Benediktsson
2 ! See http://factorcode.org/license.txt for BSD license
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
12 TUPLE: binhex name type auth flags data resource ;
17 [ , ] [ 0x90 = [ 0x00 , ] when ] bi ;
20 [ first ] [ length 255 /mod ] bi
21 [ [ dup rel90, 0x90 , 0xff , ] times rel90, ]
22 [ dup 1 > [ 0x90 , , ] [ drop ] if ] bi* ;
24 : rle90-encode ( bytes -- bytes' )
25 [ [ = ] monotonic-split-slice [ rel90% ] each ] B{ } make ;
27 : rle90-decode ( bytes -- bytes' )
35 [ 1 - over <repetition> % ] if
46 "!\"#$%&'()*+,-012345689@ABCDEFGHIJKLMNPQRSTUVXYZ[`abcdefhijklmpqr"
51 ERROR: malformed-hqx ;
57 $[ alphabet alphabet-inverse ] nth
58 [ malformed-hqx ] unless* { fixnum } declare ; inline
60 : hqx-decode ( chars -- bytes )
63 dup "\r\n\t\s" member? [ drop ] [
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 ] }
74 : hqx-encode ( bytes -- chars )
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 ] }
83 ] each 6 swap - shift ch>hqx ,
86 : crc16-binhex ( bytes -- n )
92 b 7 i - bit? [ 1 + ] when
94 [ [ 0x1021 bitxor ] when ] bi*
100 [ [ 0x1021 bitxor ] when ] bi*
103 : check-crc ( bytes -- bytes )
104 dup crc16-binhex 2 read be> assert= ;
106 : skip-return ( -- ch )
107 read1 [ dup "\r\n\t\s" member? ] [ drop read1 ] while ;
109 :: read-header ( -- name type auth flags #data #resource )
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> ;
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
128 read-header [ read check-crc ] bi@ binhex boa
131 : file>binhex ( path -- binhex )
132 binary [ read-binhex ] with-file-reader ;
137 "(This file must be converted with BinHex 4.0)" >byte-array
140 : write-with-crc ( bytes -- )
141 [ write ] [ crc16-binhex 2 >be write ] bi ;
143 : write-header ( binhex -- )
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 ]
153 ] with-byte-writer write-with-crc ;
157 : write-binhex ( binhex -- )
163 [ write-header ] [ data>> ] [ resource>> ] tri
164 [ write-with-crc ] bi@
166 rle90-encode hqx-encode
167 64 group [ CHAR: \r write1 ] [ write ] interleave
171 : binhex>file ( binhex path -- )
172 binary [ write-binhex ] with-file-writer ;