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 {

                # pad to block size
                $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;
        my $blocks = sprintf('%02x', $len / 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;
warn "DEBUG: ", as_hex($str);
        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 ) = @_;

        $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 ) {
                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			warn sprintf "## tag %9s %02d %s \|%-4s\|\n", $tag, $ord, as_hex( $data ), $data;
251			$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	# pad to block size
321			$data .= "\0" x ( 4 - ( length($data) % 4 ) );
322	dpavlin	30
323	dpavlin	38	my $max_len = 7 * 4;
324	dpavlin	30
325	dpavlin	38	if ( length($data) > $max_len ) {
326			$data = substr($data,0,$max_len);
327			warn "strip content to $max_len bytes\n";
328			}
329
330			$hex_data = unpack('H*', $data);
331			}
332
333			my $len = length($hex_data) / 2;
334			my $blocks = sprintf('%02x', $len / 4);
335
336			print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
337
338	dpavlin	29	cmd(
339	dpavlin	38	"d6 00 ff 04 $tag 00 $blocks 00 $hex_data ffff", "write $tag",
340			"d6 00 0d 04 00 $tag $blocks afb1", sub { assert() },
341	dpavlin	34	) foreach ( 1 .. 3 ); # xxx 3m software does this three times!
342	dpavlin	29
343			my $to = $path;
344			$to .= '.' . time();
345
346			rename $path, $to;
347			print ">> $to\n";
348
349	dpavlin	30	delete $tags_data->{$tag}; # force re-read of tag
350	dpavlin	29	}
351
352	dpavlin	34	sub secure_tag {
353			my ($tag) = @_;
354
355			my $path = "$secure_path/$tag";
356			my $data = substr(read_file( $path ),0,2);
357
358			cmd(
359			"d6 00 0c 09 $tag $data 1234", "secure $tag -> $data",
360			"d6 00 0c 09 00 $tag 1234", sub { assert() },
361			);
362
363			my $to = $path;
364			$to .= '.' . time();
365
366			rename $path, $to;
367			print ">> $to\n";
368			}
369
370	dpavlin	19	exit;
371
372	dpavlin	1	for ( 1 .. 3 ) {
373
374			# ++-->type 00-0a
375			# 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
376			# 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
377			# 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
378
379			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 $_" );
380			warn "D6 00 0D 04 00 E00401003123AA26 07 CFF1 -- ack 7 block?\n";
381
382			}
383			warn " D6 00 0F FE 00 00 05 01 E00401003123AA26 941A\n";
384
385			cmd( 'D6 00 05 FE 00 05 FA 40', "port-write scan $_" ) foreach ( 1 .. 2 );
386
387			cmd('D6 00 0C 09 E00401003123AA26 D7 3AF0', 'checkin?',
388			'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
389			cmd('D6 00 0C 09 E00401003123AA26 DA EB5D', 'checkout?',
390			'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
391
392			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',
393			'D6 00 0D 04 00 E00401003123AA26 06 DFD0 -- ack 6 blocks' ) foreach ( 1 .. 3 );
394
395			undef $port;
396			print "Port closed\n";
397
398			sub writechunk
399			{
400			my $str=shift;
401	dpavlin	38	warn "DEBUG: ", as_hex($str);
402	dpavlin	1	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	5	$from \|\|= 0;
444	dpavlin	4	$to = length( $assert->{expect} ) if ! defined $to;
445
446	dpavlin	2	my $p = substr( $assert->{payload}, $from, $to );
447			my $e = substr( $assert->{expect}, $from, $to );
448	dpavlin	3	warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
449	dpavlin	5
450			# return the rest
451			return substr( $assert->{payload}, $to );
452	dpavlin	2	}
453
454	dpavlin	15	use Digest::CRC;
455
456			sub crcccitt {
457			my $bytes = shift;
458			my $crc = Digest::CRC->new(
459			# midified CCITT to xor with 0xffff instead of 0x0000
460			width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
461			) or die $!;
462			$crc->add( $bytes );
463			pack('n', $crc->digest);
464			}
465
466	dpavlin	8	# my $checksum = checksum( $bytes );
467			# my $checksum = checksum( $bytes, $original_checksum );
468			sub checksum {
469			my ( $bytes, $checksum ) = @_;
470
471	dpavlin	16	my $len = ord(substr($bytes,2,1));
472	dpavlin	17	my $len_real = length($bytes) - 1;
473	dpavlin	16
474	dpavlin	17	if ( $len_real != $len ) {
475			print "length wrong: $len_real != $len\n";
476	dpavlin	38	$bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
477	dpavlin	17	}
478
479	dpavlin	38	my $xor = crcccitt( substr($bytes,1) ); # skip D6
480			warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
481
482	dpavlin	8	if ( defined $checksum && $xor ne $checksum ) {
483	dpavlin	10	print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
484	dpavlin	16	return $bytes . $xor;
485	dpavlin	8	}
486	dpavlin	16	return $bytes . $checksum;
487	dpavlin	8	}
488
489	dpavlin	20	our $dispatch;
490
491	dpavlin	1	sub readchunk {
492	dpavlin	2	sleep 1; # FIXME remove
493
494	dpavlin	1	# read header of packet
495			my $header = read_bytes( 2, 'header' );
496	dpavlin	2	my $length = read_bytes( 1, 'length' );
497			my $len = ord($length);
498	dpavlin	1	my $data = read_bytes( $len, 'data' );
499
500	dpavlin	2	my $payload = substr( $data, 0, -2 );
501			my $payload_len = length($data);
502			warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
503	dpavlin	8
504	dpavlin	2	my $checksum = substr( $data, -2, 2 );
505	dpavlin	20	checksum( $header . $length . $payload , $checksum );
506	dpavlin	1
507	dpavlin	22	print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " \| sum: ",as_hex($checksum),"\n" if $verbose;
508	dpavlin	2
509			$assert->{len} = $len;
510			$assert->{payload} = $payload;
511
512	dpavlin	20	my $full = $header . $length . $data; # full
513			# find longest match for incomming data
514			my ($to) = grep {
515			my $match = substr($payload,0,length($_));
516			m/^\Q$match\E/
517			} sort { length($a) <=> length($b) } keys %$dispatch;
518			warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
519	dpavlin	2
520	dpavlin	20	if ( defined $to ) {
521			my $rest = substr( $payload, length($to) );
522			warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
523			$dispatch->{ $to }->( $rest );
524			} else {
525			print "NO DISPATCH for ",dump( $full ),"\n";
526			}
527
528	dpavlin	2	return $data;
529	dpavlin	1	}
530
531	dpavlin	2	sub str2bytes {
532			my $str = shift \|\| confess "no str?";
533	dpavlin	5	my $b = $str;
534	dpavlin	17	$b =~ s/\s+//g;
535			$b =~ s/(..)/\\x$1/g;
536			$b = "\"$b\"";
537	dpavlin	5	my $bytes = eval $b;
538	dpavlin	2	die $@ if $@;
539	dpavlin	5	warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
540	dpavlin	2	return $bytes;
541			}
542
543			sub cmd {
544	dpavlin	20	my $cmd = shift \|\| confess "no cmd?";
545			my $cmd_desc = shift \|\| confess "no description?";
546			my @expect = @_;
547
548	dpavlin	2	my $bytes = str2bytes( $cmd );
549
550	dpavlin	16	# fix checksum if needed
551			$bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
552
553	dpavlin	22	warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
554	dpavlin	2	$assert->{send} = $cmd;
555			writechunk( $bytes );
556
557	dpavlin	20	while ( @expect ) {
558			my $pattern = str2bytes( shift @expect ) \|\| confess "no pattern?";
559			my $coderef = shift @expect \|\| confess "no coderef?";
560			confess "not coderef" unless ref $coderef eq 'CODE';
561
562			next if defined $dispatch->{ $pattern };
563
564			$dispatch->{ substr($pattern,3) } = $coderef;
565			warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
566	dpavlin	2	}
567	dpavlin	20
568			readchunk;
569	dpavlin	2	}
570