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 = IO::Socket::INET->new( $meteor_server )
         || die "can't connect to meteor $meteor_server: $!";

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

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

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 $!;

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


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