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, @_ );
                }
        );

        my $data = $tags_data->{$tag} || die "no data for $tag";
        my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
        my $set   = ( $set_item & 0xf0 ) >> 4;
        my $total = ( $set_item & 0x0f );
        my $branch  = $br_lib >> 20;
        my $library = $br_lib & 0x000fffff;
        print "TAG $tag [$u1] set: $set/$total [$u2] type: $type '$content' branch: $branch library: $library custom: $custom\n";

}

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	32	my $data = $tags_data->{$tag} \|\| die "no data for $tag";
272			my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
273			my $set = ( $set_item & 0xf0 ) >> 4;
274			my $total = ( $set_item & 0x0f );
275			my $branch = $br_lib >> 20;
276			my $library = $br_lib & 0x000fffff;
277			print "TAG $tag [$u1] set: $set/$total [$u2] type: $type '$content' branch: $branch library: $library custom: $custom\n";
278
279	dpavlin	16	}
280
281	dpavlin	29	sub write_tag {
282			my ($tag) = @_;
283
284			my $path = "$program_path/$tag";
285
286			my $data = read_file( $path );
287
288	dpavlin	30	$data = substr($data,0,16);
289	dpavlin	29
290	dpavlin	30	my $hex_data = unpack('H*', $data) . ' 00' x ( 16 - length($data) );
291
292			print "write_tag $tag = $data ",dump( $hex_data );
293
294	dpavlin	29	cmd(
295	dpavlin	30	"D6 00 26 04 $tag 00 06 00 04 11 00 01 $hex_data 00 00 00 00 FD3B", "write $tag",
296	dpavlin	29	"D6 00 0D 04 00 $tag 06 AFB1", sub { assert() },
297			) foreach ( 1 .. 3 ); # XXX 3M software does this three times!
298
299			my $to = $path;
300			$to .= '.' . time();
301
302			rename $path, $to;
303			print ">> $to\n";
304
305	dpavlin	30	delete $tags_data->{$tag}; # force re-read of tag
306	dpavlin	29	}
307
308	dpavlin	19	exit;
309
310	dpavlin	1	for ( 1 .. 3 ) {
311
312			# ++-->type 00-0a
313			# 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
314			# 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
315			# 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
316
317			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 $_" );
318			warn "D6 00 0D 04 00 E00401003123AA26 07 CFF1 -- ack 7 block?\n";
319
320			}
321			warn " D6 00 0F FE 00 00 05 01 E00401003123AA26 941A\n";
322
323			cmd( 'D6 00 05 FE 00 05 FA 40', "port-write scan $_" ) foreach ( 1 .. 2 );
324
325			cmd('D6 00 0C 09 E00401003123AA26 D7 3AF0', 'checkin?',
326			'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
327			cmd('D6 00 0C 09 E00401003123AA26 DA EB5D', 'checkout?',
328			'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
329
330			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',
331			'D6 00 0D 04 00 E00401003123AA26 06 DFD0 -- ack 6 blocks' ) foreach ( 1 .. 3 );
332
333			undef $port;
334			print "Port closed\n";
335
336			sub writechunk
337			{
338			my $str=shift;
339			my $count = $port->write($str);
340	dpavlin	19	print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
341	dpavlin	1	}
342
343			sub as_hex {
344			my @out;
345			foreach my $str ( @_ ) {
346			my $hex = unpack( 'H*', $str );
347	dpavlin	2	$hex =~ s/(..)/$1 /g if length( $str ) > 2;
348	dpavlin	8	$hex =~ s/\s+$//;
349	dpavlin	1	push @out, $hex;
350			}
351	dpavlin	8	return join(' \| ', @out);
352	dpavlin	1	}
353
354			sub read_bytes {
355			my ( $len, $desc ) = @_;
356			my $data = '';
357			while ( length( $data ) < $len ) {
358			my ( $c, $b ) = $port->read(1);
359	dpavlin	28	die "no bytes on port: $!" unless defined $b;
360	dpavlin	1	#warn "## got $c bytes: ", as_hex($b), "\n";
361			$data .= $b;
362			}
363			$desc \|\|= '?';
364	dpavlin	4	warn "#< ", as_hex($data), "\t$desc\n" if $debug;
365	dpavlin	1	return $data;
366			}
367
368	dpavlin	5	our $assert;
369	dpavlin	2
370	dpavlin	5	# my $rest = skip_assert( 3 );
371			sub skip_assert {
372			assert( 0, shift );
373			}
374
375	dpavlin	2	sub assert {
376			my ( $from, $to ) = @_;
377
378	dpavlin	5	$from \|\|= 0;
379	dpavlin	4	$to = length( $assert->{expect} ) if ! defined $to;
380
381	dpavlin	2	my $p = substr( $assert->{payload}, $from, $to );
382			my $e = substr( $assert->{expect}, $from, $to );
383	dpavlin	3	warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
384	dpavlin	5
385			# return the rest
386			return substr( $assert->{payload}, $to );
387	dpavlin	2	}
388
389	dpavlin	15	use Digest::CRC;
390
391			sub crcccitt {
392			my $bytes = shift;
393			my $crc = Digest::CRC->new(
394			# midified CCITT to xor with 0xffff instead of 0x0000
395			width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
396			) or die $!;
397			$crc->add( $bytes );
398			pack('n', $crc->digest);
399			}
400
401	dpavlin	8	# my $checksum = checksum( $bytes );
402			# my $checksum = checksum( $bytes, $original_checksum );
403			sub checksum {
404			my ( $bytes, $checksum ) = @_;
405
406	dpavlin	15	my $xor = crcccitt( substr($bytes,1) ); # skip D6
407			warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
408	dpavlin	10
409	dpavlin	16	my $len = ord(substr($bytes,2,1));
410	dpavlin	17	my $len_real = length($bytes) - 1;
411	dpavlin	16
412	dpavlin	17	if ( $len_real != $len ) {
413			print "length wrong: $len_real != $len\n";
414			$bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
415			}
416
417	dpavlin	8	if ( defined $checksum && $xor ne $checksum ) {
418	dpavlin	10	print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
419	dpavlin	16	return $bytes . $xor;
420	dpavlin	8	}
421	dpavlin	16	return $bytes . $checksum;
422	dpavlin	8	}
423
424	dpavlin	20	our $dispatch;
425
426	dpavlin	1	sub readchunk {
427	dpavlin	2	sleep 1; # FIXME remove
428
429	dpavlin	1	# read header of packet
430			my $header = read_bytes( 2, 'header' );
431	dpavlin	2	my $length = read_bytes( 1, 'length' );
432			my $len = ord($length);
433	dpavlin	1	my $data = read_bytes( $len, 'data' );
434
435	dpavlin	2	my $payload = substr( $data, 0, -2 );
436			my $payload_len = length($data);
437			warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
438	dpavlin	8
439	dpavlin	2	my $checksum = substr( $data, -2, 2 );
440	dpavlin	20	checksum( $header . $length . $payload , $checksum );
441	dpavlin	1
442	dpavlin	22	print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " \| sum: ",as_hex($checksum),"\n" if $verbose;
443	dpavlin	2
444			$assert->{len} = $len;
445			$assert->{payload} = $payload;
446
447	dpavlin	20	my $full = $header . $length . $data; # full
448			# find longest match for incomming data
449			my ($to) = grep {
450			my $match = substr($payload,0,length($_));
451			m/^\Q$match\E/
452			} sort { length($a) <=> length($b) } keys %$dispatch;
453			warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
454	dpavlin	2
455	dpavlin	20	if ( defined $to ) {
456			my $rest = substr( $payload, length($to) );
457			warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
458			$dispatch->{ $to }->( $rest );
459			} else {
460			print "NO DISPATCH for ",dump( $full ),"\n";
461			}
462
463	dpavlin	2	return $data;
464	dpavlin	1	}
465
466	dpavlin	2	sub str2bytes {
467			my $str = shift \|\| confess "no str?";
468	dpavlin	5	my $b = $str;
469	dpavlin	17	$b =~ s/\s+//g;
470			$b =~ s/(..)/\\x$1/g;
471			$b = "\"$b\"";
472	dpavlin	5	my $bytes = eval $b;
473	dpavlin	2	die $@ if $@;
474	dpavlin	5	warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
475	dpavlin	2	return $bytes;
476			}
477
478			sub cmd {
479	dpavlin	20	my $cmd = shift \|\| confess "no cmd?";
480			my $cmd_desc = shift \|\| confess "no description?";
481			my @expect = @_;
482
483	dpavlin	2	my $bytes = str2bytes( $cmd );
484
485	dpavlin	16	# fix checksum if needed
486			$bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
487
488	dpavlin	22	warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
489	dpavlin	2	$assert->{send} = $cmd;
490			writechunk( $bytes );
491
492	dpavlin	20	while ( @expect ) {
493			my $pattern = str2bytes( shift @expect ) \|\| confess "no pattern?";
494			my $coderef = shift @expect \|\| confess "no coderef?";
495			confess "not coderef" unless ref $coderef eq 'CODE';
496
497			next if defined $dispatch->{ $pattern };
498
499			$dispatch->{ substr($pattern,3) } = $coderef;
500			warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
501	dpavlin	2	}
502	dpavlin	20
503			readchunk;
504	dpavlin	2	}
505