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;

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,
) 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 $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 {
        print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";
});

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();
                } 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";

                        update_visible_tags( @tags );

                }
        }
) foreach ( 1 .. 100 );


my $tags_data;
my $visible_tags;

sub update_visible_tags {
        my @tags = @_;

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

        foreach my $tag ( @tags ) {
                if ( ! defined $last_visible_tags->{$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 ) {
                print "removed tag $tag with data ",dump( delete $tags_data->{$tag} ),"\n";
        }

        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;

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