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', 'hw 10.5.0.2', 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','stats?',
     'D6 00  0C   13  00  02 01 01 03 02 02 03  00     E778','FIXME: unimplemented', sub { assert() }  );

# start scanning for tags

cmd( 'D6 00  05   FE     00  05         FA40', "XXX scan $_",
     'D6 00  07   FE  00 00  05     00  C97B', 'no tag', sub {
dispatch( 
         'D6 00  0F   FE  00 00  05 ',# 01 E00401003123AA26  941A        # seen, serial length: 8
                sub {
                        my $rest = shift || die "no rest?";
                        my $nr = ord( substr( $rest, 0, 1 ) );
                        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 ) = @_;

        print "read_tag $tag\n";
        return if $read_cached->{ $tag }++;

        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", "$tag ready?", sub {
dispatch(       "D6 00  1F  02 00   $tag   ", sub { # 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 $blocks = ord(substr($rest,0,1));
                        my @data;
                        foreach my $nr ( 0 .. $blocks - 1 ) {
                                my $block = substr( $rest, 1 + $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->{ $tag } ), "\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 );
}

our $dispatch;
sub dispatch {
        my ( $pattern, $coderef ) = @_;

        $dispatch->{ $pattern } = $coderef;

        my $patt = substr( str2bytes($pattern), 3 ); # just payload
        my $l = length($patt);
        my $p = substr( $assert->{payload}, 0, $l );
        warn "## dispatch pattern $pattern [$l] ",dump( $patt, $p ) if $debug;

        if ( $assert->{payload} eq $assert->{expect} ) {
                warn "## no dispatch, payload expected" if $debug;
        } elsif ( $p eq $patt ) {
                # if matched call with rest of payload
                $coderef->( substr( $assert->{payload}, $l ) );
        } else {
                warn "## dispatch ignored" if $debug;
        }
}

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

sub readchunk {
        my ( $parser ) = @_;

        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;

        $parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';

        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, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;
        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 );

        if ( $expect ) {
                warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";
                $assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload
                readchunk( $coderef );
        }
}

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			cmd( 'D5 00 05 04 00 11 8C66', 'hw version?',
95			'D5 00 09 04 00 11 0A 05 00 02 7250', 'hw 10.5.0.2', sub {
96	dpavlin	5	print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n";
97	dpavlin	2	});
98	dpavlin	1
99	dpavlin	4	cmd( 'D6 00 0C 13 04 01 00 02 00 03 00 04 00 AAF2','stats?',
100	dpavlin	5	'D6 00 0C 13 00 02 01 01 03 02 02 03 00 E778','FIXME: unimplemented', sub { assert() } );
101	dpavlin	1
102	dpavlin	4	# start scanning for tags
103	dpavlin	1
104	dpavlin	5	cmd( 'D6 00 05 FE 00 05 FA40', "XXX scan $_",
105			'D6 00 07 FE 00 00 05 00 C97B', 'no tag', sub {
106			dispatch(
107			'D6 00 0F FE 00 00 05 ',# 01 E00401003123AA26 941A # seen, serial length: 8
108			sub {
109			my $rest = shift \|\| die "no rest?";
110			my $nr = ord( substr( $rest, 0, 1 ) );
111			my $tags = substr( $rest, 1 );
112	dpavlin	1
113	dpavlin	5	my $tl = length( $tags );
114			die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
115
116			my @tags;
117	dpavlin	16	push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
118	dpavlin	8	warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
119	dpavlin	16	print "seen $nr tags: ", join(',', @tags ) , "\n";
120
121	dpavlin	19	# read data from tag
122			read_tag( $_ ) foreach @tags;
123	dpavlin	16
124	dpavlin	5	}
125			) }
126
127			) foreach ( 1 .. 100 );
128
129	dpavlin	16	my $read_cached;
130	dpavlin	1
131	dpavlin	16	sub read_tag {
132			my ( $tag ) = @_;
133	dpavlin	1
134	dpavlin	16	print "read_tag $tag\n";
135			return if $read_cached->{ $tag }++;
136	dpavlin	1
137	dpavlin	18	cmd( "D6 00 0D 02 $tag 00 03 1CC4", 'read $tag offset: 0 blocks: 3',
138			"D6 00 0F FE 00 00 05 01 $tag 941A", "$tag ready?", sub {
139			dispatch( "D6 00 1F 02 00 $tag ", sub { # 03 00 00 04 11 00 01 01 00 31 32 33 34 02 00 35 36 37 38 531F\n";
140			my $rest = shift \|\| die "no rest?";
141			warn "## DATA ", dump( $rest ) if $debug;
142			my $blocks = ord(substr($rest,0,1));
143			my @data;
144			foreach my $nr ( 0 .. $blocks - 1 ) {
145			my $block = substr( $rest, 1 + $nr * 6, 6 );
146			warn "## block ",as_hex( $block ) if $debug;
147			my $ord = unpack('v',substr( $block, 0, 2 ));
148			die "got block $ord, expected block $nr from ",dump( $block ) if $ord != $nr;
149			my $data = substr( $block, 2 );
150			die "data payload should be 4 bytes" if length($data) != 4;
151			warn sprintf "## tag %08s %02d %s \|%-4s\|\n", $tag, $ord, as_hex( $data ), $data;
152			$data[ $ord ] = $data;
153			}
154			$read_cached->{ $tag } = join('', @data);
155			print "DATA $tag ",dump( $read_cached->{ $tag } ), "\n";
156			})
157			});
158	dpavlin	1
159	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
160			if (0) {
161			cmd( "D6 00 0D 02 $tag 03 04 3970", 'read offset: 3 blocks: 4' );
162
163			# D6 00 25 02 00 $tag 04 03 00 30 30 00 00 04 00 00 00 00 00
164			# $tag 05 00 00 00 00 00 06 00 00 00 00 00 B9BA
165			warn "?? D6 00 25 02 00 $tag 04 03 00 39 30 31 32 04 00 ....\n";
166			}
167			warn "?? D6 00 0F FE 00 00 05 01 $tag 941A ##### ready?\n";
168
169			}
170
171	dpavlin	19	exit;
172
173	dpavlin	1	for ( 1 .. 3 ) {
174
175			# ++-->type 00-0a
176			# 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
177			# 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
178			# 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
179
180			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 $_" );
181			warn "D6 00 0D 04 00 E00401003123AA26 07 CFF1 -- ack 7 block?\n";
182
183			}
184			warn " D6 00 0F FE 00 00 05 01 E00401003123AA26 941A\n";
185
186			cmd( 'D6 00 05 FE 00 05 FA 40', "port-write scan $_" ) foreach ( 1 .. 2 );
187
188			cmd('D6 00 0C 09 E00401003123AA26 D7 3AF0', 'checkin?',
189			'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
190			cmd('D6 00 0C 09 E00401003123AA26 DA EB5D', 'checkout?',
191			'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
192
193			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',
194			'D6 00 0D 04 00 E00401003123AA26 06 DFD0 -- ack 6 blocks' ) foreach ( 1 .. 3 );
195
196			undef $port;
197			print "Port closed\n";
198
199			sub writechunk
200			{
201			my $str=shift;
202			my $count = $port->write($str);
203	dpavlin	19	print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
204	dpavlin	1	}
205
206			sub as_hex {
207			my @out;
208			foreach my $str ( @_ ) {
209			my $hex = unpack( 'H*', $str );
210	dpavlin	2	$hex =~ s/(..)/$1 /g if length( $str ) > 2;
211	dpavlin	8	$hex =~ s/\s+$//;
212	dpavlin	1	push @out, $hex;
213			}
214	dpavlin	8	return join(' \| ', @out);
215	dpavlin	1	}
216
217			sub read_bytes {
218			my ( $len, $desc ) = @_;
219			my $data = '';
220			while ( length( $data ) < $len ) {
221			my ( $c, $b ) = $port->read(1);
222			#warn "## got $c bytes: ", as_hex($b), "\n";
223			$data .= $b;
224			}
225			$desc \|\|= '?';
226	dpavlin	4	warn "#< ", as_hex($data), "\t$desc\n" if $debug;
227	dpavlin	1	return $data;
228			}
229
230	dpavlin	5	our $assert;
231	dpavlin	2
232	dpavlin	5	# my $rest = skip_assert( 3 );
233			sub skip_assert {
234			assert( 0, shift );
235			}
236
237	dpavlin	2	sub assert {
238			my ( $from, $to ) = @_;
239
240	dpavlin	5	$from \|\|= 0;
241	dpavlin	4	$to = length( $assert->{expect} ) if ! defined $to;
242
243	dpavlin	2	my $p = substr( $assert->{payload}, $from, $to );
244			my $e = substr( $assert->{expect}, $from, $to );
245	dpavlin	3	warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
246	dpavlin	5
247			# return the rest
248			return substr( $assert->{payload}, $to );
249	dpavlin	2	}
250
251	dpavlin	5	our $dispatch;
252			sub dispatch {
253			my ( $pattern, $coderef ) = @_;
254	dpavlin	19
255			$dispatch->{ $pattern } = $coderef;
256
257	dpavlin	5	my $patt = substr( str2bytes($pattern), 3 ); # just payload
258			my $l = length($patt);
259			my $p = substr( $assert->{payload}, 0, $l );
260	dpavlin	6	warn "## dispatch pattern $pattern [$l] ",dump( $patt, $p ) if $debug;
261	dpavlin	5
262			if ( $assert->{payload} eq $assert->{expect} ) {
263	dpavlin	6	warn "## no dispatch, payload expected" if $debug;
264	dpavlin	5	} elsif ( $p eq $patt ) {
265			# if matched call with rest of payload
266			$coderef->( substr( $assert->{payload}, $l ) );
267			} else {
268	dpavlin	6	warn "## dispatch ignored" if $debug;
269	dpavlin	5	}
270			}
271
272	dpavlin	15	use Digest::CRC;
273
274			sub crcccitt {
275			my $bytes = shift;
276			my $crc = Digest::CRC->new(
277			# midified CCITT to xor with 0xffff instead of 0x0000
278			width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
279			) or die $!;
280			$crc->add( $bytes );
281			pack('n', $crc->digest);
282			}
283
284	dpavlin	8	# my $checksum = checksum( $bytes );
285			# my $checksum = checksum( $bytes, $original_checksum );
286			sub checksum {
287			my ( $bytes, $checksum ) = @_;
288
289	dpavlin	15	my $xor = crcccitt( substr($bytes,1) ); # skip D6
290			warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
291	dpavlin	10
292	dpavlin	16	my $len = ord(substr($bytes,2,1));
293	dpavlin	17	my $len_real = length($bytes) - 1;
294	dpavlin	16
295	dpavlin	17	if ( $len_real != $len ) {
296			print "length wrong: $len_real != $len\n";
297			$bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,4);
298			}
299
300	dpavlin	8	if ( defined $checksum && $xor ne $checksum ) {
301	dpavlin	10	print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
302	dpavlin	16	return $bytes . $xor;
303	dpavlin	8	}
304	dpavlin	16	return $bytes . $checksum;
305	dpavlin	8	}
306
307	dpavlin	1	sub readchunk {
308	dpavlin	2	my ( $parser ) = @_;
309	dpavlin	1
310	dpavlin	2	sleep 1; # FIXME remove
311
312	dpavlin	1	# read header of packet
313			my $header = read_bytes( 2, 'header' );
314	dpavlin	2	my $length = read_bytes( 1, 'length' );
315			my $len = ord($length);
316	dpavlin	1	my $data = read_bytes( $len, 'data' );
317
318	dpavlin	2	my $payload = substr( $data, 0, -2 );
319			my $payload_len = length($data);
320			warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
321	dpavlin	8
322	dpavlin	2	my $checksum = substr( $data, -2, 2 );
323	dpavlin	8	checksum( $header . $length . $payload, $checksum );
324	dpavlin	1
325	dpavlin	8	print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " \| sum: ",as_hex($checksum),"\n";
326	dpavlin	2
327			$assert->{len} = $len;
328			$assert->{payload} = $payload;
329
330	dpavlin	8	$parser->( $len, $payload ) if $parser && ref($parser) eq 'CODE';
331	dpavlin	2
332			return $data;
333	dpavlin	1	}
334
335	dpavlin	2	sub str2bytes {
336			my $str = shift \|\| confess "no str?";
337	dpavlin	5	my $b = $str;
338	dpavlin	17	$b =~ s/\s+//g;
339			$b =~ s/(..)/\\x$1/g;
340			$b = "\"$b\"";
341	dpavlin	5	my $bytes = eval $b;
342	dpavlin	2	die $@ if $@;
343	dpavlin	5	warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
344	dpavlin	2	return $bytes;
345			}
346
347			sub cmd {
348			my ( $cmd, $cmd_desc, $expect, $expect_desc, $coderef ) = @_;
349			my $bytes = str2bytes( $cmd );
350
351	dpavlin	16	# fix checksum if needed
352			$bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
353
354	dpavlin	2	warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n";
355			$assert->{send} = $cmd;
356			writechunk( $bytes );
357
358			if ( $expect ) {
359			warn "?? $expect", $expect_desc ? "\t## $expect_desc" : '', "\n";
360			$assert->{expect} = substr(str2bytes($expect), 3, -2); # just expected payload
361			readchunk( $coderef );
362			}
363			}
364