viewvc.cgi/RFID/3m-810.pl

#!/usr/bin/perl

use Device::SerialPort qw (:STAT);
use strict;
use warnings;

use Data::Dump qw/dump/;
use Carp qw/confess/;

my $debug = 0;

my $response = {
        'd500090400110a0500027250'                              => 'version?',
        'd60007fe00000500c97b'                                  => 'no tag in range',

        'd6000ffe00000501e00401003123aa26941a'  => 'tag #1',
        'd6000ffe00000501e0040100017c0c388e2b'  => 'rfid card',
        'd6000ffe00000501e00401003123aa2875d4'  => 'tag red-stripe',

        'd60017fe00000502e00401003123aa26e0040100017c0c38cadb' => 'tag #1 + card',
        'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
};

=head1 NAME

3m-810 - support for 3M 810 RFID reader

=head1 SYNOPSIS

3m-810.pl [DEVICE [BAUD [DATA [PARITY [STOP [FLOW]]]]]]

=head1 DESCRIPTION

Communicate with 3M 810 RFID reader and document it's protocol

=head1 SEE ALSO

L<Device::SerialPort(3)>

L<perl(1)>

L<http://stackoverflow.com/questions/149617/how-could-i-guess-a-checksum-algorithm>

=head1 AUTHOR

Dobrica Pavlinusic <dpavlin@rot13.org> L<http://www.rot13.org/~dpavlin/>

=head1 COPYRIGHT AND LICENSE

This program is free software; you may redistribute it and/or modify
it under the same terms ans Perl itself.

=cut

# your serial port.
my ($device,$baudrate,$databits,$parity,$stopbits,$handshake)=@ARGV;
$device    ||= "/dev/ttyUSB0";
$baudrate  ||= "19200";
$databits  ||= "8";
$parity    ||= "none";
$stopbits  ||= "1";
$handshake ||= "none";

my $port=new Device::SerialPort($device) || die "new($device): $!\n";
$handshake=$port->handshake($handshake);
$baudrate=$port->baudrate($baudrate);
$databits=$port->databits($databits);
$parity=$port->parity($parity);
$stopbits=$port->stopbits($stopbits);

print "## using $device $baudrate $databits $parity $stopbits\n";

# Just in case: reset our timing and buffers
$port->lookclear();
$port->read_const_time(100);
$port->read_char_time(5);

# Turn on parity checking:
#$port->stty_inpck(1);
#$port->stty_istrip(1);

# initial hand-shake with device

cmd( 'D5 00  05   04 00 11                 8C66', 'hw version?',
     'D5 00  09   04 00 11   0A 05 00 02   7250', 'hw 10.5.0.2', sub {
        print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";
});

cmd( 'D6 00  0C   13  04  01 00  02 00  03 00  04 00   AAF2','stats?',
     'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778','FIXME: unimplemented', sub { assert() }  );

# start scanning for tags

cmd( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",
     'D6 00  07   FE  00 00  05     00  C97B', 'no tag', sub {
dispatch( 
         'D6 00  0F   FE  00 00  05 ',# 01 E00401003123AA26  941A        # seen, serial length: 8
                sub {
                        my $rest = shift || die "no rest?";
                        my $nr = ord( substr( $rest, 0, 1 ) );
                        my $tags = substr( $rest, 1 );

                        my $tl = length( $tags );
                        die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;

                        my @tags;
                        push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
                        warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
                        print "seen $nr tags: ", join(',', @tags ) , "\n";

                        # XXX read first tag
                        read_tag( @tags );

                }
) }

) foreach ( 1 .. 100 );

my $read_cached;

sub read_tag {
        my ( $tag ) = @_;

        print "read_tag $tag\n";
        return if $read_cached->{ $tag }++;

        cmd(    "D6 00  0D  02      $tag   00   03     1CC4", 'read offset: 0 blocks: 3' );

        #        D6 00  1F  02 00   $tag   03   00 00   04 11 00 01   01 00   30 30 30 30   02 00   30 30 30 30    E5F4
        warn "?? D6 00  1F  02 00   $tag   03   00 00   04 11 00 01   01 00   31 32 33 34   02 00   35 36 37 38    531F\n";
if (0) {
        cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );

        #        D6 00  25  02 00   $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00   
        #                           $tag                              05 00   00 00 00 00   06 00   00 00 00 00    B9BA
        warn "?? D6 00  25  02 00   $tag   04                         03 00   39 30 31 32   04 00   ....\n";
}
        warn "?? D6 00  0F  FE  00 00  05 01   $tag  941A ##### ready?\n";

}

for ( 1 .. 3 ) {

#                                                              ++-->type 00-0a
#     D6 00  2A  04     E00401003123AA26  00  07  00  04 11 00 01 31 31 31 31 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 1C D4
#     D6 00 2A 04 E0 04 01 00 31 23 AA 26 00  07  00  04 11 00 06 32 32 32 32 32 32 32 32 32 32 32 00 00 00 00 00 00 00 00 00 00 00 00 00 32B7
#     D6 00 2A 04 E0 04 01 00 31 23 AA 26 00  07  00  04 11 00 02 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 00 00 00 00 00 00 00 00 42 1F

cmd(' D6 00  2A  04     E00401003123AA26  00  07  00  04 11 00 01 30 30 30 30 30 30 30 30 30 30 00 00 00 00 00 00 00 00 00 00 00 00 00 00   8843', "write offset 0, block: 7 -- 0000000000 $_" );
warn "D6 00  0D  04 00  E00401003123AA26  07  CFF1 -- ack 7 block?\n";

}
warn "  D6 00   0F   FE 00   00   05 01  E00401003123AA26 941A\n";

cmd( 'D6 00 05 FE 00 05 FA 40', "port-write scan $_" ) foreach ( 1 .. 2 );

cmd('D6 00  0C  09    E00401003123AA26  D7  3AF0', 'checkin?',
    'D6 00  0C  09 00 E00401003123AA26      6A44 -- no?' );
cmd('D6 00  0C  09    E00401003123AA26  DA  EB5D', 'checkout?',
    'D6 00  0C  09 00 E00401003123AA26      6A44 -- no?' );

cmd('D6 00  26  04    E00401003123AA26  00  06  00  55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55  A98B', 'blank offset: 0 blocks: 6', 
    'D6 00  0D  04 00 E00401003123AA26  06  DFD0 -- ack 6 blocks' ) foreach ( 1 .. 3 );

undef $port;
print "Port closed\n";

sub writechunk
{
        my $str=shift;
        my $count = $port->write($str);
        print "#> ", as_hex( $str ), "\t[$count]\n";
}

sub as_hex {
        my @out;
        foreach my $str ( @_ ) {
                my $hex = unpack( 'H*', $str );
                $hex =~ s/(..)/$1 /g if length( $str ) > 2;
                $hex =~ s/\s+$//;
                push @out, $hex;
        }
        return join(' | ', @out);
}

sub read_bytes {
        my ( $len, $desc ) = @_;
        my $data = '';
        while ( length( $data ) < $len ) {
                my ( $c, $b ) = $port->read(1);
                #warn "## got $c bytes: ", as_hex($b), "\n";
                $data .= $b;
        }
        $desc ||= '?';
        warn "#< ", as_hex($data), "\t$desc\n" if $debug;
        return $data;
}

our $assert;

# my $rest = skip_assert( 3 );
sub skip_assert {
        assert( 0, shift );
}

sub assert {
        my ( $from, $to ) = @_;

        $from ||= 0;
        $to = length( $assert->{expect} ) if ! defined $to;

        my $p = substr( $assert->{payload}, $from, $to );
        my $e = substr( $assert->{expect},  $from, $to );
        warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;

        # return the rest
        return substr( $assert->{payload}, $to );
}

our $dispatch;
sub dispatch {
        my ( $pattern, $coderef ) = @_;
        my $patt = substr( str2bytes($pattern), 3 ); # just payload
        my $l = length($patt);
        my $p = substr( $assert->{payload}, 0, $l );
        warn "## dispatch pattern $pattern [$l] ",dump( $patt, $p ) if $debug;

        if ( $assert->{payload} eq $assert->{expect} ) {
                warn "## no dispatch, payload expected" if $debug;
        } elsif ( $p eq $patt ) {
                # if matched call with rest of payload
                $coderef->( substr( $assert->{payload}, $l ) );
        } else {
                warn "## dispatch ignored" if $debug;
        }
}

use Digest::CRC;

sub crcccitt {
        my $bytes = shift;
        my $crc = Digest::CRC->new(
                # midified CCITT to xor with 0xffff instead of 0x0000
                width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
        ) or die $!;
        $crc->add( $bytes );
        pack('n', $crc->digest);
}

# my $checksum = checksum( $bytes );
# my $checksum = checksum( $bytes, $original_checksum );
sub checksum {
        my ( $bytes, $checksum ) = @_;

        my $xor = crcccitt( substr($bytes,1) ); # skip D6
        warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;

        my $len = ord(substr($bytes,2,1));
        my $len_real = length($bytes);
        print "length wrong: $len_real != $len\n" if $len_real != $len;

        if ( defined $checksum && $xor ne $checksum ) {
                print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
                return $bytes . $xor;
        }
        return $bytes . $checksum;
}

sub readchunk {
        my ( $parser ) = @_;

        sleep 1;        # FIXME remove

        # read header of packet
        my $header = read_bytes( 2, 'header' );
        my $length = read_bytes( 1, 'length' );
        my $len = ord($length);
        my $data = read_bytes( $len, 'data' );

        my $payload  = substr( $data, 0, -2 );
        my $payload_len = length($data);
        warn "## payload too short $payload_len != $len\n" if $payload_len != $len;

        my $checksum = substr( $data, -2, 2 );
        checksum( $header . $length . $payload, $checksum );

        print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n";

        $assert->{len}      = $len;
        $assert->{payload}  = $payload;

        $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';

        return $data;
}

sub str2bytes {
        my $str = shift || confess "no str?";
        my $b = $str;
        $b =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/;    # fix checksum
        $b =~ s/\s+$//;
        $b =~ s/\s+/\\x/g;
        $b = '"\x' . $b . '"';
        my $bytes = eval $b;
        die $@ if $@;
        warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
        return $bytes;
}

sub cmd {
        my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;
        my $bytes = str2bytes( $cmd );

        # fix checksum if needed
        $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );

        warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";
        $assert->{send} = $cmd;
        writechunk( $bytes );

        if ( $expect ) {
                warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";
                $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload
                readchunk( $coderef );
        }
}

1	dpavlin	1	#!/usr/bin/perl
2
3			use Device::SerialPort qw (:STAT);
4			use strict;
5			use warnings;
6
7			use Data::Dump qw/dump/;
8	dpavlin	2	use Carp qw/confess/;
9	dpavlin	1
10	dpavlin	4	my $debug = 0;
11
12	dpavlin	1	my $response = {
13			'd500090400110a0500027250' => 'version?',
14			'd60007fe00000500c97b' => 'no tag in range',
15
16			'd6000ffe00000501e00401003123aa26941a' => 'tag #1',
17			'd6000ffe00000501e0040100017c0c388e2b' => 'rfid card',
18			'd6000ffe00000501e00401003123aa2875d4' => 'tag red-stripe',
19
20			'd60017fe00000502e00401003123aa26e0040100017c0c38cadb' => 'tag #1 + card',
21			'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
22			};
23
24			=head1 NAME
25
26			3m-810 - support for 3M 810 RFID reader
27
28			=head1 SYNOPSIS
29
30			3m-810.pl [DEVICE [BAUD [DATA [PARITY [STOP [FLOW]]]]]]
31
32			=head1 DESCRIPTION
33
34			Communicate with 3M 810 RFID reader and document it's protocol
35
36			=head1 SEE ALSO
37
38			L<Device::SerialPort(3)>
39
40			L<perl(1)>
41
42	dpavlin	15	L<http://stackoverflow.com/questions/149617/how-could-i-guess-a-checksum-algorithm>
43
44	dpavlin	1	=head1 AUTHOR
45
46			Dobrica Pavlinusic <dpavlin@rot13.org> L<http://www.rot13.org/~dpavlin/>
47
48			=head1 COPYRIGHT AND LICENSE
49
50			This program is free software; you may redistribute it and/or modify
51			it under the same terms ans Perl itself.
52
53			=cut
54
55			# your serial port.
56			my ($device,$baudrate,$databits,$parity,$stopbits,$handshake)=@ARGV;
57			$device \|\|= "/dev/ttyUSB0";
58			$baudrate \|\|= "19200";
59			$databits \|\|= "8";
60			$parity \|\|= "none";
61			$stopbits \|\|= "1";
62			$handshake \|\|= "none";
63
64			my $port=new Device::SerialPort($device) \|\| die "new($device): $!\n";
65			$handshake=$port->handshake($handshake);
66			$baudrate=$port->baudrate($baudrate);
67			$databits=$port->databits($databits);
68			$parity=$port->parity($parity);
69			$stopbits=$port->stopbits($stopbits);
70
71			print "## using $device $baudrate $databits $parity $stopbits\n";
72
73			# Just in case: reset our timing and buffers
74			$port->lookclear();
75			$port->read_const_time(100);
76			$port->read_char_time(5);
77
78			# Turn on parity checking:
79			#$port->stty_inpck(1);
80			#$port->stty_istrip(1);
81
82	dpavlin	4	# initial hand-shake with device
83
84			cmd( 'D5 00 05 04 00 11 8C66', 'hw version?',
85			'D5 00 09 04 00 11 0A 05 00 02 7250', 'hw 10.5.0.2', sub {
86	dpavlin	5	print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";
87	dpavlin	2	});
88	dpavlin	1
89	dpavlin	4	cmd( 'D6 00 0C 13 04 01 00 02 00 03 00 04 00 AAF2','stats?',
90	dpavlin	5	'D6 00 0C 13 00 02 01 01 03 02 02 03 00 E778','FIXME: unimplemented', sub { assert() } );
91	dpavlin	1
92	dpavlin	4	# start scanning for tags
93	dpavlin	1
94	dpavlin	5	cmd( 'D6 00 05 FE 00 05 FA40', "XXX scan $_",
95			'D6 00 07 FE 00 00 05 00 C97B', 'no tag', sub {
96			dispatch(
97			'D6 00 0F FE 00 00 05 ',# 01 E00401003123AA26 941A # seen, serial length: 8
98			sub {
99			my $rest = shift \|\| die "no rest?";
100			my $nr = ord( substr( $rest, 0, 1 ) );
101			my $tags = substr( $rest, 1 );
102	dpavlin	1
103	dpavlin	5	my $tl = length( $tags );
104			die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
105
106			my @tags;
107	dpavlin	16	push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
108	dpavlin	8	warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
109	dpavlin	16	print "seen $nr tags: ", join(',', @tags ) , "\n";
110
111			# XXX read first tag
112			read_tag( @tags );
113
114	dpavlin	5	}
115			) }
116
117			) foreach ( 1 .. 100 );
118
119	dpavlin	16	my $read_cached;
120	dpavlin	1
121	dpavlin	16	sub read_tag {
122			my ( $tag ) = @_;
123	dpavlin	1
124	dpavlin	16	print "read_tag $tag\n";
125			return if $read_cached->{ $tag }++;
126	dpavlin	1
127	dpavlin	16	cmd( "D6 00 0D 02 $tag 00 03 1CC4", 'read offset: 0 blocks: 3' );
128	dpavlin	1
129	dpavlin	16	# D6 00 1F 02 00 $tag 03 00 00 04 11 00 01 01 00 30 30 30 30 02 00 30 30 30 30 E5F4
130			warn "?? D6 00 1F 02 00 $tag 03 00 00 04 11 00 01 01 00 31 32 33 34 02 00 35 36 37 38 531F\n";
131			if (0) {
132			cmd( "D6 00 0D 02 $tag 03 04 3970", 'read offset: 3 blocks: 4' );
133
134			# D6 00 25 02 00 $tag 04 03 00 30 30 00 00 04 00 00 00 00 00
135			# $tag 05 00 00 00 00 00 06 00 00 00 00 00 B9BA
136			warn "?? D6 00 25 02 00 $tag 04 03 00 39 30 31 32 04 00 ....\n";
137			}
138			warn "?? D6 00 0F FE 00 00 05 01 $tag 941A ##### ready?\n";
139
140			}
141
142	dpavlin	1	for ( 1 .. 3 ) {
143
144			# ++-->type 00-0a
145			# D6 00 2A 04 E00401003123AA26 00 07 00 04 11 00 01 31 31 31 31 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 1C D4
146			# D6 00 2A 04 E0 04 01 00 31 23 AA 26 00 07 00 04 11 00 06 32 32 32 32 32 32 32 32 32 32 32 00 00 00 00 00 00 00 00 00 00 00 00 00 32B7
147			# D6 00 2A 04 E0 04 01 00 31 23 AA 26 00 07 00 04 11 00 02 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 00 00 00 00 00 00 00 00 42 1F
148
149			cmd(' D6 00 2A 04 E00401003123AA26 00 07 00 04 11 00 01 30 30 30 30 30 30 30 30 30 30 00 00 00 00 00 00 00 00 00 00 00 00 00 00 8843', "write offset 0, block: 7 -- 0000000000 $_" );
150			warn "D6 00 0D 04 00 E00401003123AA26 07 CFF1 -- ack 7 block?\n";
151
152			}
153			warn " D6 00 0F FE 00 00 05 01 E00401003123AA26 941A\n";
154
155			cmd( 'D6 00 05 FE 00 05 FA 40', "port-write scan $_" ) foreach ( 1 .. 2 );
156
157			cmd('D6 00 0C 09 E00401003123AA26 D7 3AF0', 'checkin?',
158			'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
159			cmd('D6 00 0C 09 E00401003123AA26 DA EB5D', 'checkout?',
160			'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
161
162			cmd('D6 00 26 04 E00401003123AA26 00 06 00 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 A98B', 'blank offset: 0 blocks: 6',
163			'D6 00 0D 04 00 E00401003123AA26 06 DFD0 -- ack 6 blocks' ) foreach ( 1 .. 3 );
164
165			undef $port;
166			print "Port closed\n";
167
168			sub writechunk
169			{
170			my $str=shift;
171			my $count = $port->write($str);
172	dpavlin	6	print "#> ", as_hex( $str ), "\t[$count]\n";
173	dpavlin	1	}
174
175			sub as_hex {
176			my @out;
177			foreach my $str ( @_ ) {
178			my $hex = unpack( 'H*', $str );
179	dpavlin	2	$hex =~ s/(..)/$1 /g if length( $str ) > 2;
180	dpavlin	8	$hex =~ s/\s+$//;
181	dpavlin	1	push @out, $hex;
182			}
183	dpavlin	8	return join(' \| ', @out);
184	dpavlin	1	}
185
186			sub read_bytes {
187			my ( $len, $desc ) = @_;
188			my $data = '';
189			while ( length( $data ) < $len ) {
190			my ( $c, $b ) = $port->read(1);
191			#warn "## got $c bytes: ", as_hex($b), "\n";
192			$data .= $b;
193			}
194			$desc \|\|= '?';
195	dpavlin	4	warn "#< ", as_hex($data), "\t$desc\n" if $debug;
196	dpavlin	1	return $data;
197			}
198
199	dpavlin	5	our $assert;
200	dpavlin	2
201	dpavlin	5	# my $rest = skip_assert( 3 );
202			sub skip_assert {
203			assert( 0, shift );
204			}
205
206	dpavlin	2	sub assert {
207			my ( $from, $to ) = @_;
208
209	dpavlin	5	$from \|\|= 0;
210	dpavlin	4	$to = length( $assert->{expect} ) if ! defined $to;
211
212	dpavlin	2	my $p = substr( $assert->{payload}, $from, $to );
213			my $e = substr( $assert->{expect}, $from, $to );
214	dpavlin	3	warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
215	dpavlin	5
216			# return the rest
217			return substr( $assert->{payload}, $to );
218	dpavlin	2	}
219
220	dpavlin	5	our $dispatch;
221			sub dispatch {
222			my ( $pattern, $coderef ) = @_;
223			my $patt = substr( str2bytes($pattern), 3 ); # just payload
224			my $l = length($patt);
225			my $p = substr( $assert->{payload}, 0, $l );
226	dpavlin	6	warn "## dispatch pattern $pattern [$l] ",dump( $patt, $p ) if $debug;
227	dpavlin	5
228			if ( $assert->{payload} eq $assert->{expect} ) {
229	dpavlin	6	warn "## no dispatch, payload expected" if $debug;
230	dpavlin	5	} elsif ( $p eq $patt ) {
231			# if matched call with rest of payload
232			$coderef->( substr( $assert->{payload}, $l ) );
233			} else {
234	dpavlin	6	warn "## dispatch ignored" if $debug;
235	dpavlin	5	}
236			}
237
238	dpavlin	15	use Digest::CRC;
239
240			sub crcccitt {
241			my $bytes = shift;
242			my $crc = Digest::CRC->new(
243			# midified CCITT to xor with 0xffff instead of 0x0000
244			width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
245			) or die $!;
246			$crc->add( $bytes );
247			pack('n', $crc->digest);
248			}
249
250	dpavlin	8	# my $checksum = checksum( $bytes );
251			# my $checksum = checksum( $bytes, $original_checksum );
252			sub checksum {
253			my ( $bytes, $checksum ) = @_;
254
255	dpavlin	15	my $xor = crcccitt( substr($bytes,1) ); # skip D6
256			warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
257	dpavlin	10
258	dpavlin	16	my $len = ord(substr($bytes,2,1));
259			my $len_real = length($bytes);
260			print "length wrong: $len_real != $len\n" if $len_real != $len;
261
262	dpavlin	8	if ( defined $checksum && $xor ne $checksum ) {
263	dpavlin	10	print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
264	dpavlin	16	return $bytes . $xor;
265	dpavlin	8	}
266	dpavlin	16	return $bytes . $checksum;
267	dpavlin	8	}
268
269	dpavlin	1	sub readchunk {
270	dpavlin	2	my ( $parser ) = @_;
271	dpavlin	1
272	dpavlin	2	sleep 1; # FIXME remove
273
274	dpavlin	1	# read header of packet
275			my $header = read_bytes( 2, 'header' );
276	dpavlin	2	my $length = read_bytes( 1, 'length' );
277			my $len = ord($length);
278	dpavlin	1	my $data = read_bytes( $len, 'data' );
279
280	dpavlin	2	my $payload = substr( $data, 0, -2 );
281			my $payload_len = length($data);
282			warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
283	dpavlin	8
284	dpavlin	2	my $checksum = substr( $data, -2, 2 );
285	dpavlin	8	checksum( $header . $length . $payload, $checksum );
286	dpavlin	1
287	dpavlin	8	print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " \| sum: ",as_hex($checksum),"\n";
288	dpavlin	2
289			$assert->{len} = $len;
290			$assert->{payload} = $payload;
291
292	dpavlin	8	$parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';
293	dpavlin	2
294			return $data;
295	dpavlin	1	}
296
297	dpavlin	2	sub str2bytes {
298			my $str = shift \|\| confess "no str?";
299	dpavlin	5	my $b = $str;
300			$b =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/; # fix checksum
301			$b =~ s/\s+$//;
302			$b =~ s/\s+/\\x/g;
303			$b = '"\x' . $b . '"';
304			my $bytes = eval $b;
305	dpavlin	2	die $@ if $@;
306	dpavlin	5	warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
307	dpavlin	2	return $bytes;
308			}
309
310			sub cmd {
311			my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;
312			my $bytes = str2bytes( $cmd );
313
314	dpavlin	16	# fix checksum if needed
315			$bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
316
317	dpavlin	2	warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";
318			$assert->{send} = $cmd;
319			writechunk( $bytes );
320
321			if ( $expect ) {
322			warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";
323			$assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload
324			readchunk( $coderef );
325			}
326			}
327