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/;
use Getopt::Long;

my $debug = 0;

my $device    = "/dev/ttyUSB0";
my $baudrate  = "19200";
my $databits  = "8";
my $parity        = "none";
my $stopbits  = "1";
my $handshake = "none";

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',
};

GetOptions(
        'd|debug+'      => \$debug,
        'device=s'    => \$device,
        'baudrate=i'  => \$baudrate,
        'databits=i'  => \$databits,
        'parity=s'    => \$parity,
        'stopbits=i'  => \$stopbits,
        'handshake=s' => \$handshake,
) or die $!;

=head1 NAME

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

=head1 SYNOPSIS

3m-810.pl --device /dev/ttyUSB0

=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

my $tags_data;
my $visible_tags;

my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";
warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
$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', 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','FIXME: stats?',
     'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778', sub { assert() }  );

# start scanning for tags

cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
     'D6 00  07   FE  00 00  05     00  C97B', sub {
                assert();
                print "no tag in range\n";

        },
         'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
                my $rest = shift || die "no rest?";
                my $nr = ord( substr( $rest, 0, 1 ) );

                if ( ! $nr ) {
                        print "no tags in range\n";
                } else {

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

                        my $removed_tags = $visible_tags;
                        $visible_tags = {};

                        foreach my $tag ( @tags ) {
                                next if $visible_tags->{$tag}++;
                                read_tag( $tag );
                                if ( delete $removed_tags->{$tag} ) {
                                        print "removed tag $tag\n";
                                }
                        }

                }
        }
) foreach ( 1 .. 100 );

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

        print "read_tag $tag\n";

        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", sub {
                        print "FIXME: tag $tag ready?\n";
                },
                "D6 00  1F  02 00", sub { # $tag  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 $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
                        my $blocks = ord(substr($rest,8,1));
                        $rest = substr($rest,9); # leave just data blocks
                        my @data;
                        foreach my $nr ( 0 .. $blocks - 1 ) {
                                my $block = substr( $rest, $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;
                        }
                        $tags_data->{ $tag } = join('', @data);
                        print "DATA $tag ",dump( $tags_data ), "\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";

}

exit;

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

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

our $dispatch;

sub readchunk {
        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;

        my $full = $header . $length . $data; # full
        # find longest match for incomming data
        my ($to) = grep {
                my $match = substr($payload,0,length($_));
                m/^\Q$match\E/
        } sort { length($a) <=> length($b) } keys %$dispatch;
        warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;

        if ( defined $to ) {
                my $rest = substr( $payload, length($to) );
                warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
                $dispatch->{ $to }->( $rest );
        } else {
                print "NO DISPATCH for ",dump( $full ),"\n";
        }

        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 = shift || confess "no cmd?";
        my $cmd_desc = shift || confess "no description?";
        my @expect = @_;

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

        while ( @expect ) {
                my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
                my $coderef = shift @expect || confess "no coderef?";
                confess "not coderef" unless ref $coderef eq 'CODE';

                next if defined $dispatch->{ $pattern };

                $dispatch->{ substr($pattern,3) } = $coderef;
                warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
        }

        readchunk;
}

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