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 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 ) {
                $meteor_fh = IO::Socket::INET->new( $meteor_server )
                        || 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 $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
        }

        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;
}


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";
                        my $rest = shift || die "no rest?";
                        warn "## DATA ", 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
                        my @data;
                        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 ));
                                die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;
                                my $data  = substr( $block, 2 );
                                die "data payload should be 4 bytes" if length($data) != 4;
                                warn sprintf "## tag %08s %02d %s |%-4s|\n", $tag, $ord, as_hex( $data ), $data;
                                $data[ $ord ] = $data;
                        }
                        $tags_data->{ $tag } = join('', @data);
                        print "DATA $tag ",dump( $tags_data ), "\n";
                }
        );

        #        D6 00  1F  02 00   $tag   03   00 00   04 11 00 01   01 00   30 30 30 30   02 00   30 30 30 30    E5F4
if (0) {
        cmd(    "D6 00  0D  02      $tag   03   04     3970", 'read offset: 3 blocks: 4' );

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