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 $security;

        cmd(
                "D6 00 0B 0A $tag 1234", "check security $tag",
                "D6 00 0D 0A 00", sub {
                        my $rest = shift;
                        my $from_tag;
                        ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
                        die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
                        $security = as_hex( $security );
                        warn "# SECURITY $tag = $security\n";
                }
        );

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