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 $secure_path = './secure/';

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 );
                }
                if ( -e "$secure_path/$tag" ) {
                                meteor( 'secure', $tag );
                                secure_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
}

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

        my $path = "$secure_path/$tag";
        my $data = substr(read_file( $path ),0,2);

        cmd(
                "d6 00  0c  09  $tag $data 1234", "secure $tag -> $data",
                "d6 00  0c  09 00  $tag  1234", sub { assert() },
        );

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

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

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