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;

use IO::Socket::INET;

my $meteor_server = '192.168.1.13:4671';
my $meteor_fh;

sub meteor {
        my @a = @_;
        push @a, scalar localtime() if $a[0] =~ m{^info};

        if ( ! defined $meteor_fh ) {
                warn "# open connection to $meteor_server";
                $meteor_fh = IO::Socket::INET->new(
                                PeerAddr => $meteor_server,
                                Timeout => 1,
                ) || warn "can't connect to meteor $meteor_server: $!"; # FIXME warn => die for production
                $meteor_fh = 0; # don't try again
        }

        warn ">> meteor ",dump( @a );
        print $meteor_fh "ADDMESSAGE test ",join('|',@a),"\n" if $meteor_fh;
}

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,
        'meteor=s'    => \$meteor_server,
) or die $!;

my $verbose = $debug > 0 ? $debug-- : 0;

=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 debug: $debug verbose: $verbose\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 {
        my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
        print "hardware version $hw_ver\n";
        meteor( 'info', "Found reader hardware $hw_ver" );
});

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  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";
                        update_visible_tags();
                        meteor( 'info-none-in-range' );
                        $tags_data = {};
                } 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 "$nr tags in range: ", join(',', @tags ) , "\n";

                        meteor( 'info-in-range', join(' ',@tags));

                        update_visible_tags( @tags );
                }
        }
) while(1);
#) foreach ( 1 .. 100 );


sub update_visible_tags {
        my @tags = @_;

        my $last_visible_tags = $visible_tags;
        $visible_tags = {};

        foreach my $tag ( @tags ) {
                if ( ! defined $last_visible_tags->{$tag} ) {
                        if ( defined $tags_data->{$tag} ) {
#                               meteor( 'in-range', $tag );
                        } else {
                                meteor( 'read', $tag );
                                read_tag( $tag );
                        }
                        $visible_tags->{$tag}++;
                } else {
                        warn "## using cached data for $tag" if $debug;
                }
                delete $last_visible_tags->{$tag}; # leave just missing tags
        }

        foreach my $tag ( keys %$last_visible_tags ) {
                my $data = delete $tags_data->{$tag};
                print "removed tag $tag with data ",dump( $data ),"\n";
                meteor( 'removed', $tag );
        }

        warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
}

my $tag_data_block;

sub read_tag_data {
        my ($start_block,$rest) = @_;
        die "no rest?" unless $rest;
        warn "## DATA [$start_block] ", 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
        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 ));
                my $expected_ord = $nr + $start_block;
                die "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
                my $data  = substr( $block, 2 );
                die "data payload should be 4 bytes" if length($data) != 4;
                warn sprintf "## tag %9s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
                $tag_data_block->{$tag}->[ $ord ] = $data;
        }
        $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
        print "DATA $tag ",dump( $tags_data ), "\n";
}

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

        confess "no tag?" unless $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";
                        read_tag_data( 0, @_ );
                },
        );

        cmd(
                "D6 00  0D  02      $tag   03   04     3970", "read $tag offset: 3 blocks: 4",
                "D6 00  25  02 00", sub { # $tag   04                         03 00   30 30 00 00   04 00   00 00 00 00   
                        read_tag_data( 3, @_ );
                }
        );

}

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);
                die "no bytes on port: $!" unless defined $b;
                #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" if $verbose;

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