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 ) {
                $meteor_fh = IO::Socket::INET->new( $meteor_server )
                        || 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;
}


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