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/';

# 3M defaults: 8,4
my $max_rfid_block = 16;
my $read_blocks = 8;

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;

        my $last_block = 0;

        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;
                warn "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;
                $last_block = $ord;
        }
        $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";

        return $last_block;
}

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

        confess "no tag?" unless $tag;

        print "read_tag $tag\n";

        my $start_block = 0;

        while ( $start_block < $max_rfid_block ) {

                cmd(
                         sprintf( "D6 00  0D  02      $tag   %02x   %02x     ffff", $start_block, $read_blocks ),
                                "read $tag offset: $start_block blocks: $read_blocks",
                        "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";
                                $start_block = read_tag_data( $start_block, @_ );
                                warn "# read tag upto $start_block\n";
                        },
                        "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
                                print "FIXME: tag $tag ready? (expected block read instead)\n";
                        },
                );

        }

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