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

sub meteor {
        my ( $item, $html ) = @_;
        warn ">> meteor $item $html\n";
        print $meteor "ADDMESSAGE test $item|" . localtime() . "<br>$html\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( -1, "Found reader $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( -1, "No tags in range" );
                } 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";

                        update_visible_tags( @tags );

                        my $html = join('', map { "<li><tt>$_</tt>" } @tags);
                        meteor( 0, "Tags:<ul>$html</ul>" );
                }
        }
) foreach ( 1 .. 1000 );


sub update_visible_tags {
        my @tags = @_;

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

        foreach my $tag ( @tags ) {
                if ( ! defined $last_visible_tags->{$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";
        }

        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;

        return if defined $tags_data->{$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";

        my $item = unpack('H*', substr($tag,-8) ) % 100000;
        meteor( $item, "Loading $item" );

}

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