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 $!;

=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\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  07   FE  00 00  05     00  C97B', sub {
                assert();
                print "no tag in range\n";

        },
         '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";
                } 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 "seen $nr tags: ", join(',', @tags ) , "\n";

                        # read data from tag
                        read_tag( $_ ) foreach @tags;

                }
        }
) foreach ( 1 .. 100 );

my $read_cached;

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

        return if $read_cached->{ $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;
                        }
                        $read_cached->{ $tag } = join('', @data);
                        print "DATA $tag ",dump( $read_cached ), "\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";

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