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 ) {
                if ( $meteor_fh =
                                IO::Socket::INET->new(
                                        PeerAddr => $meteor_server,
                                        Timeout => 1,
                                )
                ) {
                        warn "# meteor connected to $meteor_server";
                } else {
                        warn "can't connect to meteor $meteor_server: $!";
                        $meteor_fh = 0;
                }
        }

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

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' library: $library branch: $branch custom: $custom security: $security\n";

}

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

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

        my $data = read_file( $path );
        my $hex_data;

        if ( $data =~ s{^hex\s+}{} ) {
                $hex_data = $data;
                $hex_data =~ s{\s+}{}g;
        } else {

                $data .= "\0" x ( 4 - ( length($data) % 4 ) );

                my $max_len = 7 * 4;

                if ( length($data) > $max_len ) {
                        $data = substr($data,0,$max_len);
                        warn "strip content to $max_len bytes\n";
                }

                $hex_data = unpack('H*', $data);
        }

        my $len = length($hex_data) / 2;
        # pad to block size
        $hex_data .= '00' x ( 4 - $len % 4 );
        my $blocks = sprintf('%02x', length($hex_data) / 4);

        print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";

        cmd(
                "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  ffff", "write $tag",
                "d6 00  0d  04 00  $tag  $blocks  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);
        my $len = length($str);
        die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
        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 ) = @_;

        return unless $assert->{expect};

        $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 $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,3);
        }

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

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