viewvc.cgi/RFID/3m-810.pl

#!/usr/bin/perl

use Device::SerialPort qw (:STAT);
use strict;
use warnings;

use Data::Dump qw/dump/;
use Carp qw/confess/;
use Getopt::Long;
use File::Slurp;

use IO::Socket::INET;

my $meteor_server = '192.168.1.13:4671';
my $meteor_fh;

sub meteor {
        my @a = @_;
        push @a, scalar localtime() if $a[0] =~ m{^info};

        if ( ! defined $meteor_fh ) {
                warn "# open connection to $meteor_server";
                $meteor_fh = IO::Socket::INET->new(
                                PeerAddr => $meteor_server,
                                Timeout => 1,
                ) || warn "can't connect to meteor $meteor_server: $!"; # FIXME warn => die for production
                $meteor_fh = 0; # don't try again
        }

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

my $debug = 0;

my $device    = "/dev/ttyUSB0";
my $baudrate  = "19200";
my $databits  = "8";
my $parity        = "none";
my $stopbits  = "1";
my $handshake = "none";

my $program_path = './program/';

my $response = {
        'd500090400110a0500027250'                              => 'version?',
        'd60007fe00000500c97b'                                  => 'no tag in range',

        'd6000ffe00000501e00401003123aa26941a'  => 'tag #1',
        'd6000ffe00000501e0040100017c0c388e2b'  => 'rfid card',
        'd6000ffe00000501e00401003123aa2875d4'  => 'tag red-stripe',

        'd60017fe00000502e00401003123aa26e0040100017c0c38cadb' => 'tag #1 + card',
        'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
};

GetOptions(
        'd|debug+'    => \$debug,
        'device=s'    => \$device,
        'baudrate=i'  => \$baudrate,
        'databits=i'  => \$databits,
        'parity=s'    => \$parity,
        'stopbits=i'  => \$stopbits,
        'handshake=s' => \$handshake,
        'meteor=s'    => \$meteor_server,
) or die $!;

my $verbose = $debug > 0 ? $debug-- : 0;

=head1 NAME

3m-810 - support for 3M 810 RFID reader

=head1 SYNOPSIS

3m-810.pl --device /dev/ttyUSB0

=head1 DESCRIPTION

Communicate with 3M 810 RFID reader and document it's protocol

=head1 SEE ALSO

L<Device::SerialPort(3)>

L<perl(1)>

L<http://stackoverflow.com/questions/149617/how-could-i-guess-a-checksum-algorithm>

=head1 AUTHOR

Dobrica Pavlinusic <dpavlin@rot13.org> L<http://www.rot13.org/~dpavlin/>

=head1 COPYRIGHT AND LICENSE

This program is free software; you may redistribute it and/or modify
it under the same terms ans Perl itself.

=cut

my $tags_data;
my $visible_tags;

my $port=new Device::SerialPort($device) || die "can't open serial port $device: $!\n";
warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
$handshake=$port->handshake($handshake);
$baudrate=$port->baudrate($baudrate);
$databits=$port->databits($databits);
$parity=$port->parity($parity);
$stopbits=$port->stopbits($stopbits);

print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";

# Just in case: reset our timing and buffers
$port->lookclear();
$port->read_const_time(100);
$port->read_char_time(5);

# Turn on parity checking:
#$port->stty_inpck(1);
#$port->stty_istrip(1);

# initial hand-shake with device

cmd( 'D5 00  05   04 00 11                 8C66', 'hw version',
     'D5 00  09   04 00 11   0A 05 00 02   7250', sub {
        my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
        print "hardware version $hw_ver\n";
        meteor( 'info', "Found reader hardware $hw_ver" );
});

cmd( 'D6 00  0C   13  04  01 00  02 00  03 00  04 00   AAF2','FIXME: stats?',
     'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778', sub { assert() }  );

# start scanning for tags

cmd( 'D6 00  05   FE     00  05         FA40', "scan for tags, retry $_",
         'D6 00  0F   FE  00 00  05 ', sub { # 01 E00401003123AA26  941A         # seen, serial length: 8
                my $rest = shift || die "no rest?";
                my $nr = ord( substr( $rest, 0, 1 ) );

                if ( ! $nr ) {
                        print "no tags in range\n";
                        update_visible_tags();
                        meteor( 'info-none-in-range' );
                        $tags_data = {};
                } else {

                        my $tags = substr( $rest, 1 );

                        my $tl = length( $tags );
                        die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;

                        my @tags;
                        push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
                        warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
                        print "$nr tags in range: ", join(',', @tags ) , "\n";

                        meteor( 'info-in-range', join(' ',@tags));

                        update_visible_tags( @tags );
                }
        }
) while(1);
#) foreach ( 1 .. 100 );


sub update_visible_tags {
        my @tags = @_;

        my $last_visible_tags = $visible_tags;
        $visible_tags = {};

        foreach my $tag ( @tags ) {
                if ( ! defined $last_visible_tags->{$tag} ) {
                        if ( defined $tags_data->{$tag} ) {
#                               meteor( 'in-range', $tag );
                        } else {
                                meteor( 'read', $tag );
                                read_tag( $tag );
                        }
                        $visible_tags->{$tag}++;
                } else {
                        warn "## using cached data for $tag" if $debug;
                }
                delete $last_visible_tags->{$tag}; # leave just missing tags

                if ( -e "$program_path/$tag" ) {
                                meteor( 'write', $tag );
                                write_tag( $tag );
                }
        }

        foreach my $tag ( keys %$last_visible_tags ) {
                my $data = delete $tags_data->{$tag};
                print "removed tag $tag with data ",dump( $data ),"\n";
                meteor( 'removed', $tag );
        }

        warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
}

my $tag_data_block;

sub read_tag_data {
        my ($start_block,$rest) = @_;
        die "no rest?" unless $rest;
        warn "## DATA [$start_block] ", dump( $rest ) if $debug;
        my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
        my $blocks = ord(substr($rest,8,1));
        $rest = substr($rest,9); # leave just data blocks
        foreach my $nr ( 0 .. $blocks - 1 ) {
                my $block = substr( $rest, $nr * 6, 6 );
                warn "## block ",as_hex( $block ) if $debug;
                my $ord   = unpack('v',substr( $block, 0, 2 ));
                my $expected_ord = $nr + $start_block;
                die "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
                my $data  = substr( $block, 2 );
                die "data payload should be 4 bytes" if length($data) != 4;
                warn sprintf "## tag %9s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
                $tag_data_block->{$tag}->[ $ord ] = $data;
        }
        $tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
        print "DATA $tag ",dump( $tags_data ), "\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, @_ );
                }
        );

}

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

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

        my $data = read_file( $path );

        print "write_tag $tag = $data\n";

        cmd(
                "D6 00  26  04  $tag  00 06 00  04 11 00 01  61 61 61 61  62 62 62 62  63 63 63 63  64 64 64 64  00 00 00 00  FD3B", "write $tag",
                "D6 00  0D  04 00  $tag  06  AFB1", sub { assert() },
        ) foreach ( 1 .. 3 ); # XXX 3M software does this three times!

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

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

}

exit;

for ( 1 .. 3 ) {

#                                                              ++-->type 00-0a
#     D6 00  2A  04     E00401003123AA26  00  07  00  04 11 00 01 31 31 31 31 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 1C D4
#     D6 00 2A 04 E0 04 01 00 31 23 AA 26 00  07  00  04 11 00 06 32 32 32 32 32 32 32 32 32 32 32 00 00 00 00 00 00 00 00 00 00 00 00 00 32B7
#     D6 00 2A 04 E0 04 01 00 31 23 AA 26 00  07  00  04 11 00 02 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 00 00 00 00 00 00 00 00 42 1F

cmd(' D6 00  2A  04     E00401003123AA26  00  07  00  04 11 00 01 30 30 30 30 30 30 30 30 30 30 00 00 00 00 00 00 00 00 00 00 00 00 00 00   8843', "write offset 0, block: 7 -- 0000000000 $_" );
warn "D6 00  0D  04 00  E00401003123AA26  07  CFF1 -- ack 7 block?\n";

}
warn "  D6 00   0F   FE 00   00   05 01  E00401003123AA26 941A\n";

cmd( 'D6 00 05 FE 00 05 FA 40', "port-write scan $_" ) foreach ( 1 .. 2 );

cmd('D6 00  0C  09    E00401003123AA26  D7  3AF0', 'checkin?',
    'D6 00  0C  09 00 E00401003123AA26      6A44 -- no?' );
cmd('D6 00  0C  09    E00401003123AA26  DA  EB5D', 'checkout?',
    'D6 00  0C  09 00 E00401003123AA26      6A44 -- no?' );

cmd('D6 00  26  04    E00401003123AA26  00  06  00  55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55 55  A98B', 'blank offset: 0 blocks: 6', 
    'D6 00  0D  04 00 E00401003123AA26  06  DFD0 -- ack 6 blocks' ) foreach ( 1 .. 3 );

undef $port;
print "Port closed\n";

sub writechunk
{
        my $str=shift;
        my $count = $port->write($str);
        print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
}

sub as_hex {
        my @out;
        foreach my $str ( @_ ) {
                my $hex = unpack( 'H*', $str );
                $hex =~ s/(..)/$1 /g if length( $str ) > 2;
                $hex =~ s/\s+$//;
                push @out, $hex;
        }
        return join(' | ', @out);
}

sub read_bytes {
        my ( $len, $desc ) = @_;
        my $data = '';
        while ( length( $data ) < $len ) {
                my ( $c, $b ) = $port->read(1);
                die "no bytes on port: $!" unless defined $b;
                #warn "## got $c bytes: ", as_hex($b), "\n";
                $data .= $b;
        }
        $desc ||= '?';
        warn "#< ", as_hex($data), "\t$desc\n" if $debug;
        return $data;
}

our $assert;

# my $rest = skip_assert( 3 );
sub skip_assert {
        assert( 0, shift );
}

sub assert {
        my ( $from, $to ) = @_;

        $from ||= 0;
        $to = length( $assert->{expect} ) if ! defined $to;

        my $p = substr( $assert->{payload}, $from, $to );
        my $e = substr( $assert->{expect},  $from, $to );
        warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;

        # return the rest
        return substr( $assert->{payload}, $to );
}

use Digest::CRC;

sub crcccitt {
        my $bytes = shift;
        my $crc = Digest::CRC->new(
                # midified CCITT to xor with 0xffff instead of 0x0000
                width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
        ) or die $!;
        $crc->add( $bytes );
        pack('n', $crc->digest);
}

# my $checksum = checksum( $bytes );
# my $checksum = checksum( $bytes, $original_checksum );
sub checksum {
        my ( $bytes, $checksum ) = @_;

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

        my $len = ord(substr($bytes,2,1));
        my $len_real = length($bytes) - 1;

        if ( $len_real != $len ) {
                print "length wrong: $len_real != $len\n";
                $bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
        }

        if ( defined $checksum && $xor ne $checksum ) {
                print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
                return $bytes . $xor;
        }
        return $bytes . $checksum;
}

our $dispatch;

sub readchunk {
        sleep 1;        # FIXME remove

        # read header of packet
        my $header = read_bytes( 2, 'header' );
        my $length = read_bytes( 1, 'length' );
        my $len = ord($length);
        my $data = read_bytes( $len, 'data' );

        my $payload  = substr( $data, 0, -2 );
        my $payload_len = length($data);
        warn "## payload too short $payload_len != $len\n" if $payload_len != $len;

        my $checksum = substr( $data, -2, 2 );
        checksum( $header . $length . $payload , $checksum );

        print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " | sum: ",as_hex($checksum),"\n" if $verbose;

        $assert->{len}      = $len;
        $assert->{payload}  = $payload;

        my $full = $header . $length . $data; # full
        # find longest match for incomming data
        my ($to) = grep {
                my $match = substr($payload,0,length($_));
                m/^\Q$match\E/
        } sort { length($a) <=> length($b) } keys %$dispatch;
        warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;

        if ( defined $to ) {
                my $rest = substr( $payload, length($to) );
                warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
                $dispatch->{ $to }->( $rest );
        } else {
                print "NO DISPATCH for ",dump( $full ),"\n";
        }

        return $data;
}

sub str2bytes {
        my $str = shift || confess "no str?";
        my $b = $str;
        $b =~ s/\s+//g;
        $b =~ s/(..)/\\x$1/g;
        $b = "\"$b\"";
        my $bytes = eval $b;
        die $@ if $@;
        warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
        return $bytes;
}

sub cmd {
        my $cmd = shift || confess "no cmd?";
        my $cmd_desc = shift || confess "no description?";
        my @expect = @_;

        my $bytes = str2bytes( $cmd );

        # fix checksum if needed
        $bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );

        warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
        $assert->{send} = $cmd;
        writechunk( $bytes );

        while ( @expect ) {
                my $pattern = str2bytes( shift @expect ) || confess "no pattern?";
                my $coderef = shift @expect || confess "no coderef?";
                confess "not coderef" unless ref $coderef eq 'CODE';

                next if defined $dispatch->{ $pattern };

                $dispatch->{ substr($pattern,3) } = $coderef;
                warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
        }

        readchunk;
}

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