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

                        update_visible_tags( @tags );

                        my $html = join('', map { "<li><tt>$_</tt>" } @tags);
                        meteor( 0, "Tags:<ul>$html</ul>" );
                }
        }
) 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} ) {
                        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	24	$tags_data = {};
131	dpavlin	20	} else {
132
133	dpavlin	5	my $tags = substr( $rest, 1 );
134	dpavlin	1
135	dpavlin	5	my $tl = length( $tags );
136			die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
137
138			my @tags;
139	dpavlin	16	push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
140	dpavlin	8	warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
141	dpavlin	22	print "$nr tags in range: ", join(',', @tags ) , "\n";
142	dpavlin	16
143	dpavlin	22	update_visible_tags( @tags );
144	dpavlin	16
145	dpavlin	23	my $html = join('', map { "<li><tt>$_</tt>" } @tags);
146			meteor( 0, "Tags:<ul>$html</ul>" );
147	dpavlin	5	}
148	dpavlin	20	}
149	dpavlin	24	) while(1);
150			#) foreach ( 1 .. 100 );
151	dpavlin	5
152	dpavlin	22
153
154			sub update_visible_tags {
155			my @tags = @_;
156
157			my $last_visible_tags = $visible_tags;
158			$visible_tags = {};
159
160			foreach my $tag ( @tags ) {
161			if ( ! defined $last_visible_tags->{$tag} ) {
162			read_tag( $tag );
163			$visible_tags->{$tag}++;
164			} else {
165			warn "## using cached data for $tag" if $debug;
166			}
167			delete $last_visible_tags->{$tag}; # leave just missing tags
168			}
169
170			foreach my $tag ( keys %$last_visible_tags ) {
171	dpavlin	23	my $data = delete $tags_data->{$tag};
172			print "removed tag $tag with data ",dump( $data ),"\n";
173	dpavlin	22	}
174
175			warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
176			}
177
178
179	dpavlin	16	sub read_tag {
180			my ( $tag ) = @_;
181	dpavlin	1
182	dpavlin	22	confess "no tag?" unless $tag;
183
184			return if defined $tags_data->{$tag};
185
186	dpavlin	16	print "read_tag $tag\n";
187	dpavlin	1
188	dpavlin	20	cmd(
189			"D6 00 0D 02 $tag 00 03 1CC4", 'read $tag offset: 0 blocks: 3',
190			"D6 00 0F FE 00 00 05 01 $tag 941A", sub {
191			print "FIXME: tag $tag ready?\n";
192			},
193			"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";
194	dpavlin	18	my $rest = shift \|\| die "no rest?";
195			warn "## DATA ", dump( $rest ) if $debug;
196	dpavlin	20	my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
197			my $blocks = ord(substr($rest,8,1));
198			$rest = substr($rest,9); # leave just data blocks
199	dpavlin	18	my @data;
200			foreach my $nr ( 0 .. $blocks - 1 ) {
201	dpavlin	20	my $block = substr( $rest, $nr * 6, 6 );
202	dpavlin	18	warn "## block ",as_hex( $block ) if $debug;
203			my $ord = unpack('v',substr( $block, 0, 2 ));
204			die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;
205			my $data = substr( $block, 2 );
206			die "data payload should be 4 bytes" if length($data) != 4;
207			warn sprintf "## tag %08s %02d %s \|%-4s\|\n", $tag, $ord, as_hex( $data ), $data;
208			$data[ $ord ] = $data;
209			}
210	dpavlin	21	$tags_data->{ $tag } = join('', @data);
211			print "DATA $tag ",dump( $tags_data ), "\n";
212	dpavlin	20	}
213			);
214	dpavlin	1
215	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
216			if (0) {
217			cmd( "D6 00 0D 02 $tag 03 04 3970", 'read offset: 3 blocks: 4' );
218
219			# D6 00 25 02 00 $tag 04 03 00 30 30 00 00 04 00 00 00 00 00
220			# $tag 05 00 00 00 00 00 06 00 00 00 00 00 B9BA
221			warn "?? D6 00 25 02 00 $tag 04 03 00 39 30 31 32 04 00 ....\n";
222			}
223			warn "?? D6 00 0F FE 00 00 05 01 $tag 941A ##### ready?\n";
224
225	dpavlin	23	my $item = unpack('H*', substr($tag,-8) ) % 100000;
226			meteor( $item, "Loading $item" );
227
228	dpavlin	16	}
229
230	dpavlin	19	exit;
231
232	dpavlin	1	for ( 1 .. 3 ) {
233
234			# ++-->type 00-0a
235			# 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
236			# 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
237			# 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
238
239			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 $_" );
240			warn "D6 00 0D 04 00 E00401003123AA26 07 CFF1 -- ack 7 block?\n";
241
242			}
243			warn " D6 00 0F FE 00 00 05 01 E00401003123AA26 941A\n";
244
245			cmd( 'D6 00 05 FE 00 05 FA 40', "port-write scan $_" ) foreach ( 1 .. 2 );
246
247			cmd('D6 00 0C 09 E00401003123AA26 D7 3AF0', 'checkin?',
248			'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
249			cmd('D6 00 0C 09 E00401003123AA26 DA EB5D', 'checkout?',
250			'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
251
252			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',
253			'D6 00 0D 04 00 E00401003123AA26 06 DFD0 -- ack 6 blocks' ) foreach ( 1 .. 3 );
254
255			undef $port;
256			print "Port closed\n";
257
258			sub writechunk
259			{
260			my $str=shift;
261			my $count = $port->write($str);
262	dpavlin	19	print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
263	dpavlin	1	}
264
265			sub as_hex {
266			my @out;
267			foreach my $str ( @_ ) {
268			my $hex = unpack( 'H*', $str );
269	dpavlin	2	$hex =~ s/(..)/$1 /g if length( $str ) > 2;
270	dpavlin	8	$hex =~ s/\s+$//;
271	dpavlin	1	push @out, $hex;
272			}
273	dpavlin	8	return join(' \| ', @out);
274	dpavlin	1	}
275
276			sub read_bytes {
277			my ( $len, $desc ) = @_;
278			my $data = '';
279			while ( length( $data ) < $len ) {
280			my ( $c, $b ) = $port->read(1);
281			#warn "## got $c bytes: ", as_hex($b), "\n";
282			$data .= $b;
283			}
284			$desc \|\|= '?';
285	dpavlin	4	warn "#< ", as_hex($data), "\t$desc\n" if $debug;
286	dpavlin	1	return $data;
287			}
288
289	dpavlin	5	our $assert;
290	dpavlin	2
291	dpavlin	5	# my $rest = skip_assert( 3 );
292			sub skip_assert {
293			assert( 0, shift );
294			}
295
296	dpavlin	2	sub assert {
297			my ( $from, $to ) = @_;
298
299	dpavlin	5	$from \|\|= 0;
300	dpavlin	4	$to = length( $assert->{expect} ) if ! defined $to;
301
302	dpavlin	2	my $p = substr( $assert->{payload}, $from, $to );
303			my $e = substr( $assert->{expect}, $from, $to );
304	dpavlin	3	warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
305	dpavlin	5
306			# return the rest
307			return substr( $assert->{payload}, $to );
308	dpavlin	2	}
309
310	dpavlin	15	use Digest::CRC;
311
312			sub crcccitt {
313			my $bytes = shift;
314			my $crc = Digest::CRC->new(
315			# midified CCITT to xor with 0xffff instead of 0x0000
316			width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
317			) or die $!;
318			$crc->add( $bytes );
319			pack('n', $crc->digest);
320			}
321
322	dpavlin	8	# my $checksum = checksum( $bytes );
323			# my $checksum = checksum( $bytes, $original_checksum );
324			sub checksum {
325			my ( $bytes, $checksum ) = @_;
326
327	dpavlin	15	my $xor = crcccitt( substr($bytes,1) ); # skip D6
328			warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
329	dpavlin	10
330	dpavlin	16	my $len = ord(substr($bytes,2,1));
331	dpavlin	17	my $len_real = length($bytes) - 1;
332	dpavlin	16
333	dpavlin	17	if ( $len_real != $len ) {
334			print "length wrong: $len_real != $len\n";
335			$bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
336			}
337
338	dpavlin	8	if ( defined $checksum && $xor ne $checksum ) {
339	dpavlin	10	print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
340	dpavlin	16	return $bytes . $xor;
341	dpavlin	8	}
342	dpavlin	16	return $bytes . $checksum;
343	dpavlin	8	}
344
345	dpavlin	20	our $dispatch;
346
347	dpavlin	1	sub readchunk {
348	dpavlin	2	sleep 1; # FIXME remove
349
350	dpavlin	1	# read header of packet
351			my $header = read_bytes( 2, 'header' );
352	dpavlin	2	my $length = read_bytes( 1, 'length' );
353			my $len = ord($length);
354	dpavlin	1	my $data = read_bytes( $len, 'data' );
355
356	dpavlin	2	my $payload = substr( $data, 0, -2 );
357			my $payload_len = length($data);
358			warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
359	dpavlin	8
360	dpavlin	2	my $checksum = substr( $data, -2, 2 );
361	dpavlin	20	checksum( $header . $length . $payload , $checksum );
362	dpavlin	1
363	dpavlin	22	print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " \| sum: ",as_hex($checksum),"\n" if $verbose;
364	dpavlin	2
365			$assert->{len} = $len;
366			$assert->{payload} = $payload;
367
368	dpavlin	20	my $full = $header . $length . $data; # full
369			# find longest match for incomming data
370			my ($to) = grep {
371			my $match = substr($payload,0,length($_));
372			m/^\Q$match\E/
373			} sort { length($a) <=> length($b) } keys %$dispatch;
374			warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
375	dpavlin	2
376	dpavlin	20	if ( defined $to ) {
377			my $rest = substr( $payload, length($to) );
378			warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
379			$dispatch->{ $to }->( $rest );
380			} else {
381			print "NO DISPATCH for ",dump( $full ),"\n";
382			}
383
384	dpavlin	2	return $data;
385	dpavlin	1	}
386
387	dpavlin	2	sub str2bytes {
388			my $str = shift \|\| confess "no str?";
389	dpavlin	5	my $b = $str;
390	dpavlin	17	$b =~ s/\s+//g;
391			$b =~ s/(..)/\\x$1/g;
392			$b = "\"$b\"";
393	dpavlin	5	my $bytes = eval $b;
394	dpavlin	2	die $@ if $@;
395	dpavlin	5	warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
396	dpavlin	2	return $bytes;
397			}
398
399			sub cmd {
400	dpavlin	20	my $cmd = shift \|\| confess "no cmd?";
401			my $cmd_desc = shift \|\| confess "no description?";
402			my @expect = @_;
403
404	dpavlin	2	my $bytes = str2bytes( $cmd );
405
406	dpavlin	16	# fix checksum if needed
407			$bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
408
409	dpavlin	22	warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
410	dpavlin	2	$assert->{send} = $cmd;
411			writechunk( $bytes );
412
413	dpavlin	20	while ( @expect ) {
414			my $pattern = str2bytes( shift @expect ) \|\| confess "no pattern?";
415			my $coderef = shift @expect \|\| confess "no coderef?";
416			confess "not coderef" unless ref $coderef eq 'CODE';
417
418			next if defined $dispatch->{ $pattern };
419
420			$dispatch->{ substr($pattern,3) } = $coderef;
421			warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
422	dpavlin	2	}
423	dpavlin	20
424			readchunk;
425	dpavlin	2	}
426