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 File::Slurp;

use IO::Socket::INET;

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

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

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

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

my $debug = 0;

my $device    = "/dev/ttyUSB0";
my $baudrate  = "19200";
my $databits  = "8";
my $parity        = "none";
my $stopbits  = "1";
my $handshake = "none";

my $program_path = './program/';

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 $item_type = {
        1 => 'Book',
        6 => 'CD/CD ROM',
        2 => 'Magazine',
        13 => 'Book with Audio Tape',
        9 => 'Book with CD/CD ROM',
        0 => 'Other',

        5 => 'Video',
        4 => 'Audio Tape',
        3 => 'Bound Journal',
        8 => 'Book with Diskette',
        7 => 'Diskette',
};

warn "## known item type: ",dump( $item_type ) if $debug;

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

                if ( -e "$program_path/$tag" ) {
                                meteor( 'write', $tag );
                                write_tag( $tag );
                }
        }

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

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

my $tag_data_block;

sub read_tag_data {
        my ($start_block,$rest) = @_;
        die "no rest?" unless $rest;
        warn "## DATA [$start_block] ", dump( $rest ) if $debug;
        my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
        my $blocks = ord(substr($rest,8,1));
        $rest = substr($rest,9); # leave just data blocks
        foreach my $nr ( 0 .. $blocks - 1 ) {
                my $block = substr( $rest, $nr * 6, 6 );
                warn "## block ",as_hex( $block ) if $debug;
                my $ord   = unpack('v',substr( $block, 0, 2 ));
                my $expected_ord = $nr + $start_block;
                die "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
                my $data  = substr( $block, 2 );
                die "data payload should be 4 bytes" if length($data) != 4;
                warn sprintf "## tag %9s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
                $tag_data_block->{$tag}->[ $ord ] = $data;
        }
        $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });

        my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
        print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr' in " . dump( $item_type ) ), "\n";
}

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

        confess "no tag?" unless $tag;

        print "read_tag $tag\n";

        cmd(
                "D6 00  0D  02      $tag   00   03     1CC4", "read $tag offset: 0 blocks: 3",
                "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
                        print "FIXME: tag $tag ready?\n";
                },
                "D6 00  1F  02 00", sub { # $tag  03   00 00   04 11 00 01   01 00   31 32 33 34   02 00   35 36 37 38    531F\n";
                        read_tag_data( 0, @_ );
                },
        );

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

}

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

        my $path = "$program_path/$tag";

        my $data = read_file( $path );

        $data = substr($data,0,16);

        my $hex_data = unpack('H*', $data) . ' 00' x ( 16 - length($data) );

        print "write_tag $tag = $data ",dump( $hex_data );

        cmd(
                "D6 00  26  04  $tag  00 06 00  04 11 00 01  $hex_data 00 00 00 00  FD3B", "write $tag",
                "D6 00  0D  04 00  $tag  06  AFB1", sub { assert() },
        ) foreach ( 1 .. 3 ); # XXX 3M software does this three times!

        my $to = $path;
        $to .= '.' . time();

        rename $path, $to;
        print ">> $to\n";

        delete $tags_data->{$tag};      # force re-read of tag
}

exit;

for ( 1 .. 3 ) {

#                                                              ++-->type 00-0a
#     D6 00  2A  04     E00401003123AA26  00  07  00  04 11 00 01 31 31 31 31 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 1C D4
#     D6 00 2A 04 E0 04 01 00 31 23 AA 26 00  07  00  04 11 00 06 32 32 32 32 32 32 32 32 32 32 32 00 00 00 00 00 00 00 00 00 00 00 00 00 32B7
#     D6 00 2A 04 E0 04 01 00 31 23 AA 26 00  07  00  04 11 00 02 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 00 00 00 00 00 00 00 00 42 1F

cmd(' D6 00  2A  04     E00401003123AA26  00  07  00  04 11 00 01 30 30 30 30 30 30 30 30 30 30 00 00 00 00 00 00 00 00 00 00 00 00 00 00   8843', "write offset 0, block: 7 -- 0000000000 $_" );
warn "D6 00  0D  04 00  E00401003123AA26  07  CFF1 -- ack 7 block?\n";

}
warn "  D6 00   0F   FE 00   00   05 01  E00401003123AA26 941A\n";

cmd( 'D6 00 05 FE 00 05 FA 40', "port-write scan $_" ) foreach ( 1 .. 2 );

cmd('D6 00  0C  09    E00401003123AA26  D7  3AF0', 'checkin?',
    'D6 00  0C  09 00 E00401003123AA26      6A44 -- no?' );
cmd('D6 00  0C  09    E00401003123AA26  DA  EB5D', 'checkout?',
    'D6 00  0C  09 00 E00401003123AA26      6A44 -- no?' );

cmd('D6 00  26  04    E00401003123AA26  00  06  00  55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55  A98B', 'blank offset: 0 blocks: 6', 
    'D6 00  0D  04 00 E00401003123AA26  06  DFD0 -- ack 6 blocks' ) foreach ( 1 .. 3 );

undef $port;
print "Port closed\n";

sub writechunk
{
        my $str=shift;
        my $count = $port->write($str);
        print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
}

sub as_hex {
        my @out;
        foreach my $str ( @_ ) {
                my $hex = unpack( 'H*', $str );
                $hex =~ s/(..)/$1 /g if length( $str ) > 2;
                $hex =~ s/\s+$//;
                push @out, $hex;
        }
        return join(' | ', @out);
}

sub read_bytes {
        my ( $len, $desc ) = @_;
        my $data = '';
        while ( length( $data ) < $len ) {
                my ( $c, $b ) = $port->read(1);
                die "no bytes on port: $!" unless defined $b;
                #warn "## got $c bytes: ", as_hex($b), "\n";
                $data .= $b;
        }
        $desc ||= '?';
        warn "#< ", as_hex($data), "\t$desc\n" if $debug;
        return $data;
}

our $assert;

# my $rest = skip_assert( 3 );
sub skip_assert {
        assert( 0, shift );
}

sub assert {
        my ( $from, $to ) = @_;

        $from ||= 0;
        $to = length( $assert->{expect} ) if ! defined $to;

        my $p = substr( $assert->{payload}, $from, $to );
        my $e = substr( $assert->{expect},  $from, $to );
        warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;

        # return the rest
        return substr( $assert->{payload}, $to );
}

use Digest::CRC;

sub crcccitt {
        my $bytes = shift;
        my $crc = Digest::CRC->new(
                # midified CCITT to xor with 0xffff instead of 0x0000
                width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
        ) or die $!;
        $crc->add( $bytes );
        pack('n', $crc->digest);
}

# my $checksum = checksum( $bytes );
# my $checksum = checksum( $bytes, $original_checksum );
sub checksum {
        my ( $bytes, $checksum ) = @_;

        my $xor = crcccitt( substr($bytes,1) ); # skip D6
        warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;

        my $len = ord(substr($bytes,2,1));
        my $len_real = length($bytes) - 1;

        if ( $len_real != $len ) {
                print "length wrong: $len_real != $len\n";
                $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
        }

        if ( defined $checksum && $xor ne $checksum ) {
                print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
                return $bytes . $xor;
        }
        return $bytes . $checksum;
}

our $dispatch;

sub readchunk {
        sleep 1;        # FIXME remove

        # read header of packet
        my $header = read_bytes( 2, 'header' );
        my $length = read_bytes( 1, 'length' );
        my $len = ord($length);
        my $data = read_bytes( $len, 'data' );

        my $payload  = substr( $data, 0, -2 );
        my $payload_len = length($data);
        warn "## payload too short $payload_len != $len\n" if $payload_len != $len;

        my $checksum = substr( $data, -2, 2 );
        checksum( $header . $length . $payload , $checksum );

        print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n" if $verbose;

        $assert->{len}      = $len;
        $assert->{payload}  = $payload;

        my $full = $header . $length . $data; # full
        # find longest match for incomming data
        my ($to) = grep {
                my $match = substr($payload,0,length($_));
                m/^\Q$match\E/
        } sort { length($a) <=> length($b) } keys %$dispatch;
        warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;

        if ( defined $to ) {
                my $rest = substr( $payload, length($to) );
                warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
                $dispatch->{ $to }->( $rest );
        } else {
                print "NO DISPATCH for ",dump( $full ),"\n";
        }

        return $data;
}

sub str2bytes {
        my $str = shift || confess "no str?";
        my $b = $str;
        $b =~ s/\s+//g;
        $b =~ s/(..)/\\x$1/g;
        $b = "\"$b\"";
        my $bytes = eval $b;
        die $@ if $@;
        warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
        return $bytes;
}

sub cmd {
        my $cmd = shift || confess "no cmd?";
        my $cmd_desc = shift || confess "no description?";
        my @expect = @_;

        my $bytes = str2bytes( $cmd );

        # fix checksum if needed
        $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );

        warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
        $assert->{send} = $cmd;
        writechunk( $bytes );

        while ( @expect ) {
                my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
                my $coderef = shift @expect || confess "no coderef?";
                confess "not coderef" unless ref $coderef eq 'CODE';

                next if defined $dispatch->{ $pattern };

                $dispatch->{ substr($pattern,3) } = $coderef;
                warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
        }

        readchunk;
}

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