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, substr($tags, $_ * 8, 8) foreach ( 0 .. $nr - 1 );
                        warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
                        print "seen $nr tags: ", join(',', map { unpack('H16', $_) } @tags ) , "\n";
                }
) }

) foreach ( 1 .. 100 );

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

#     D6 00  1F  02 00   E00401003123AA26   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   E00401003123AA26   03   00 00   04 11 00 01   01 00   31 32 33 34   02 00   35 36 37 38    531F\n";

cmd( 'D6 00  0D  02      E00401003123AA26   03   04     3970', 'read offset: 3 blocks: 4' );

#     D6 00  25  02 00   E00401003123AA26   04                         03 00   30 30 00 00   04 00   00 00 00 00   
#                                                                      05 00   00 00 00 00   06 00   00 00 00 00    B9BA
warn "D6 00  25  02 00   E00401003123AA26   04                         03 00   39 30 31 32   04 00   33 34 35 36
                                                                       05 00   00 00 00 00   06 00   00 00 00 00    524B\n";
warn "D6 00  0F  FE  00 00  05 01   E00401003123AA26  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;

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

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 );

        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			push @tags, substr($tags, $_ * 8, 8) foreach ( 0 .. $nr - 1 );
108	dpavlin	8	warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
109	dpavlin	5	print "seen $nr tags: ", join(',', map { unpack('H16', $_) } @tags ) , "\n";
110			}
111			) }
112
113			) foreach ( 1 .. 100 );
114
115	dpavlin	1	cmd( 'D6 00 0D 02 E00401003123AA26 00 03 1CC4', 'read offset: 0 blocks: 3' );
116
117			# D6 00 1F 02 00 E00401003123AA26 03 00 00 04 11 00 01 01 00 30 30 30 30 02 00 30 30 30 30 E5F4
118			warn "D6 00 1F 02 00 E00401003123AA26 03 00 00 04 11 00 01 01 00 31 32 33 34 02 00 35 36 37 38 531F\n";
119
120			cmd( 'D6 00 0D 02 E00401003123AA26 03 04 3970', 'read offset: 3 blocks: 4' );
121
122			# D6 00 25 02 00 E00401003123AA26 04 03 00 30 30 00 00 04 00 00 00 00 00
123			# 05 00 00 00 00 00 06 00 00 00 00 00 B9BA
124			warn "D6 00 25 02 00 E00401003123AA26 04 03 00 39 30 31 32 04 00 33 34 35 36
125			05 00 00 00 00 00 06 00 00 00 00 00 524B\n";
126			warn "D6 00 0F FE 00 00 05 01 E00401003123AA26 941A ##### ready?\n";
127
128			for ( 1 .. 3 ) {
129
130			# ++-->type 00-0a
131			# 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
132			# 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
133			# 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
134
135			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 $_" );
136			warn "D6 00 0D 04 00 E00401003123AA26 07 CFF1 -- ack 7 block?\n";
137
138			}
139			warn " D6 00 0F FE 00 00 05 01 E00401003123AA26 941A\n";
140
141			cmd( 'D6 00 05 FE 00 05 FA 40', "port-write scan $_" ) foreach ( 1 .. 2 );
142
143			cmd('D6 00 0C 09 E00401003123AA26 D7 3AF0', 'checkin?',
144			'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
145			cmd('D6 00 0C 09 E00401003123AA26 DA EB5D', 'checkout?',
146			'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
147
148			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',
149			'D6 00 0D 04 00 E00401003123AA26 06 DFD0 -- ack 6 blocks' ) foreach ( 1 .. 3 );
150
151			undef $port;
152			print "Port closed\n";
153
154			sub writechunk
155			{
156			my $str=shift;
157			my $count = $port->write($str);
158	dpavlin	6	print "#> ", as_hex( $str ), "\t[$count]\n";
159	dpavlin	1	}
160
161			sub as_hex {
162			my @out;
163			foreach my $str ( @_ ) {
164			my $hex = unpack( 'H*', $str );
165	dpavlin	2	$hex =~ s/(..)/$1 /g if length( $str ) > 2;
166	dpavlin	8	$hex =~ s/\s+$//;
167	dpavlin	1	push @out, $hex;
168			}
169	dpavlin	8	return join(' \| ', @out);
170	dpavlin	1	}
171
172			sub read_bytes {
173			my ( $len, $desc ) = @_;
174			my $data = '';
175			while ( length( $data ) < $len ) {
176			my ( $c, $b ) = $port->read(1);
177			#warn "## got $c bytes: ", as_hex($b), "\n";
178			$data .= $b;
179			}
180			$desc \|\|= '?';
181	dpavlin	4	warn "#< ", as_hex($data), "\t$desc\n" if $debug;
182	dpavlin	1	return $data;
183			}
184
185	dpavlin	5	our $assert;
186	dpavlin	2
187	dpavlin	5	# my $rest = skip_assert( 3 );
188			sub skip_assert {
189			assert( 0, shift );
190			}
191
192	dpavlin	2	sub assert {
193			my ( $from, $to ) = @_;
194
195	dpavlin	5	$from \|\|= 0;
196	dpavlin	4	$to = length( $assert->{expect} ) if ! defined $to;
197
198	dpavlin	2	my $p = substr( $assert->{payload}, $from, $to );
199			my $e = substr( $assert->{expect}, $from, $to );
200	dpavlin	3	warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
201	dpavlin	5
202			# return the rest
203			return substr( $assert->{payload}, $to );
204	dpavlin	2	}
205
206	dpavlin	5	our $dispatch;
207			sub dispatch {
208			my ( $pattern, $coderef ) = @_;
209			my $patt = substr( str2bytes($pattern), 3 ); # just payload
210			my $l = length($patt);
211			my $p = substr( $assert->{payload}, 0, $l );
212	dpavlin	6	warn "## dispatch pattern $pattern [$l] ",dump( $patt, $p ) if $debug;
213	dpavlin	5
214			if ( $assert->{payload} eq $assert->{expect} ) {
215	dpavlin	6	warn "## no dispatch, payload expected" if $debug;
216	dpavlin	5	} elsif ( $p eq $patt ) {
217			# if matched call with rest of payload
218			$coderef->( substr( $assert->{payload}, $l ) );
219			} else {
220	dpavlin	6	warn "## dispatch ignored" if $debug;
221	dpavlin	5	}
222			}
223
224	dpavlin	15	use Digest::CRC;
225
226			sub crcccitt {
227			my $bytes = shift;
228			my $crc = Digest::CRC->new(
229			# midified CCITT to xor with 0xffff instead of 0x0000
230			width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
231			) or die $!;
232			$crc->add( $bytes );
233			pack('n', $crc->digest);
234			}
235
236	dpavlin	8	# my $checksum = checksum( $bytes );
237			# my $checksum = checksum( $bytes, $original_checksum );
238			sub checksum {
239			my ( $bytes, $checksum ) = @_;
240
241	dpavlin	15	my $xor = crcccitt( substr($bytes,1) ); # skip D6
242			warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
243	dpavlin	10
244	dpavlin	8	if ( defined $checksum && $xor ne $checksum ) {
245	dpavlin	10	print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
246	dpavlin	8	}
247			}
248
249	dpavlin	1	sub readchunk {
250	dpavlin	2	my ( $parser ) = @_;
251	dpavlin	1
252	dpavlin	2	sleep 1; # FIXME remove
253
254	dpavlin	1	# read header of packet
255			my $header = read_bytes( 2, 'header' );
256	dpavlin	2	my $length = read_bytes( 1, 'length' );
257			my $len = ord($length);
258	dpavlin	1	my $data = read_bytes( $len, 'data' );
259
260	dpavlin	2	my $payload = substr( $data, 0, -2 );
261			my $payload_len = length($data);
262			warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
263	dpavlin	8
264	dpavlin	2	my $checksum = substr( $data, -2, 2 );
265	dpavlin	8	checksum( $header . $length . $payload, $checksum );
266	dpavlin	1
267	dpavlin	8	print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " \| sum: ",as_hex($checksum),"\n";
268	dpavlin	2
269			$assert->{len} = $len;
270			$assert->{payload} = $payload;
271
272	dpavlin	8	$parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';
273	dpavlin	2
274			return $data;
275	dpavlin	1	}
276
277	dpavlin	2	sub str2bytes {
278			my $str = shift \|\| confess "no str?";
279	dpavlin	5	my $b = $str;
280			$b =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/; # fix checksum
281			$b =~ s/\s+$//;
282			$b =~ s/\s+/\\x/g;
283			$b = '"\x' . $b . '"';
284			my $bytes = eval $b;
285	dpavlin	2	die $@ if $@;
286	dpavlin	5	warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
287	dpavlin	2	return $bytes;
288			}
289
290			sub cmd {
291			my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;
292			my $bytes = str2bytes( $cmd );
293
294			warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";
295			$assert->{send} = $cmd;
296			writechunk( $bytes );
297
298			if ( $expect ) {
299			warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";
300			$assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload
301			readchunk( $coderef );
302			}
303			}
304