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 $tag offset: 0 blocks: 3',
                        "D6 00  0F  FE  00 00  05 01   $tag    941A", "$tag ready?", sub {
dispatch(       "D6 00  1F  02 00   $tag   ", sub { # 03   00 00   04 11 00 01   01 00   31 32 33 34   02 00   35 36 37 38    531F\n";
                        my $rest = shift || die "no rest?";
                        warn "## DATA ", dump( $rest ) if $debug;
                        my $blocks = ord(substr($rest,0,1));
                        my @data;
                        foreach my $nr ( 0 .. $blocks - 1 ) {
                                my $block = substr( $rest, 1 + $nr * 6, 6 );
                                warn "## block ",as_hex( $block ) if $debug;
                                my $ord   = unpack('v',substr( $block, 0, 2 ));
                                die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;
                                my $data  = substr( $block, 2 );
                                die "data payload should be 4 bytes" if length($data) != 4;
                                warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
                                $data[ $ord ] = $data;
                        }
                        $read_cached->{ $tag } = join('', @data);
                        print "DATA $tag ",dump( $read_cached->{ $tag } ), "\n";
                })
        });

        #        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
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]" if $debug;
}

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

        if ( $len_real != $len ) {
                print "length wrong: $len_real != $len\n";
                $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
        }

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