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

#!/usr/bin/perl

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

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

use IO::Socket::INET;

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

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

        if ( ! defined $meteor_fh ) {
                if ( $meteor_fh =
                                IO::Socket::INET->new(
                                        PeerAddr => $meteor_server,
                                        Timeout => 1,
                                )
                ) {
                        warn "# meteor connected to $meteor_server";
                } else {
                        warn "can't connect to meteor $meteor_server: $!";
                        $meteor_fh = 0;
                }
        }

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

my $listen_port = 9000;                  # pick something not in use
sub http_server {

        my $server = IO::Socket::INET->new(
                Proto     => 'tcp',
                LocalPort => $listen_port,
                Listen    => SOMAXCONN,
                Reuse     => 1
        );
                                                                  
        die "can't setup server" unless $server;

        print "Server $0 accepting clients at http://localhost:$listen_port/\n";

        sub static {
                my ($client,$path) = @_;

                $path = "www/$path";

                return unless -e $path;

                my $type = 'text/plain';
                $type = 'text/html' if $path =~ m{\.htm};
                $type = 'application/javascript' if $path =~ m{\.js};

                print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\n\r\n";
                open(my $html, $path);
                while(<$html>) {
                        print $client $_;
                }
                close($html);

                return $path;
        }

        while (my $client = $server->accept()) {
                $client->autoflush(1);
                my $request = <$client>;

                warn "<< $request\n";

                if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
                        my $method = $1;
                        if ( my $path = static( $client,$1 ) ) {
                                warn ">> $path";
                        } elsif ( $method =~ m{/scan} ) {
                                print $client "HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\n\r\n";
                                my $tags = scan_for_tags();
                                print $client "tags: ",dump($tags);
                                my $json;
                                map { $json->{$_} = decode_tag($_) } keys %$tags;
                                print $client "decoded: ",dump( $json );
                        } else {
                                print $client "HTTP/1.0 404 Unkown method\r\n";
                        }
                } else {
                        print $client "HTTP/1.0 500 No method\r\n";
                }
                close $client;
        }

        die "server died";
}

my $debug = 0;

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

my $program_path = './program/';
my $secure_path = './secure/';

# http server
my $http_server = 1;

# 3M defaults: 8,4
my $max_rfid_block = 16;
my $read_blocks = 8;

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 $item_type = {
        1 => 'Book',
        6 => 'CD/CD ROM',
        2 => 'Magazine',
        13 => 'Book with Audio Tape',
        9 => 'Book with CD/CD ROM',
        0 => 'Other',

        5 => 'Video',
        4 => 'Audio Tape',
        3 => 'Bound Journal',
        8 => 'Book with Diskette',
        7 => 'Diskette',
};

warn "## known item type: ",dump( $item_type ) if $debug;

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

sub scan_for_tags {

        my @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;

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

        warn "## tags: ",dump( @tags );
        return $tags_data;

}

# start scanning for tags

if ( $http_server ) {
        http_server;
} else {
        scan_for_tags while 1;
}

die "over and out";

sub update_visible_tags {
        my @tags = @_;

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

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

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

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

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

my $tag_data_block;

sub read_tag_data {
        my ($start_block,$rest) = @_;
        die "no rest?" unless $rest;

        my $last_block = 0;

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

        my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
        print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } || "UNKWOWN '$item_type_nr'" ), "\n";

        return $last_block + 1;
}

sub decode_tag {
        my $tag = shift;

        my $data = $tags_data->{$tag} || die "no data for $tag";

        my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
        my $hash = {
                u1 => $u1,
                u2 => $u2,
                set => ( $set_item & 0xf0 ) >> 4,
                total => ( $set_item & 0x0f ),

                type => $type,
                content => $content,

                branch => $br_lib >> 20,
                library => $br_lib & 0x000fffff,

                custom => $custom,
        };

        return $hash;
}

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

        confess "no tag?" unless $tag;

        print "read_tag $tag\n";

        my $start_block = 0;

        while ( $start_block < $max_rfid_block ) {

                cmd(
                         sprintf( "D6 00  0D  02      $tag   %02x   %02x     ffff", $start_block, $read_blocks ),
                                "read $tag offset: $start_block blocks: $read_blocks",
                        "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";
                                $start_block = read_tag_data( $start_block, @_ );
                                warn "# read tag upto $start_block\n";
                        },
                        "D6 00  0F  FE  00 00  05 01   $tag    941A", sub {
                                print "FIXME: tag $tag ready? (expected block read instead)\n";
                        },
                );

        }

        my $security;

        cmd(
                "D6 00 0B 0A $tag 1234", "check security $tag",
                "D6 00 0D 0A 00", sub {
                        my $rest = shift;
                        my $from_tag;
                        ( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
                        die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
                        $security = as_hex( $security );
                        warn "# SECURITY $tag = $security\n";
                }
        );

        print "TAG $tag ", dump(decode_tag( $tag ));
}

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

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

        my $data = read_file( $path );
        my $hex_data;

        if ( $data =~ s{^hex\s+}{} ) {
                $hex_data = $data;
                $hex_data =~ s{\s+}{}g;
        } else {

                $data .= "\0" x ( 4 - ( length($data) % 4 ) );

                my $max_len = $max_rfid_block * 4;

                if ( length($data) > $max_len ) {
                        $data = substr($data,0,$max_len);
                        warn "strip content to $max_len bytes\n";
                }

                $hex_data = unpack('H*', $data);
        }

        my $len = length($hex_data) / 2;
        # pad to block size
        $hex_data .= '00' x ( 4 - $len % 4 );
        my $blocks = sprintf('%02x', length($hex_data) / 4);

        print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";

        cmd(
                "d6 00  ff  04  $tag  00 $blocks 00  $hex_data  ffff", "write $tag",
                "d6 00  0d  04 00  $tag  $blocks  afb1", sub { assert() },
        ); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!

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

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

        delete $tags_data->{$tag};      # force re-read of tag
}

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

        my $path = "$secure_path/$tag";
        my $data = substr(read_file( $path ),0,2);

        cmd(
                "d6 00  0c  09  $tag $data 1234", "secure $tag -> $data",
                "d6 00  0c  09 00  $tag  1234", sub { assert() },
        );

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

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

exit;

for ( 1 .. 3 ) {

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

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

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

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

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

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

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

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

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

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

our $assert;

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

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

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

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

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

use Digest::CRC;

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

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

        my $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,3);
        }

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

        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) ) if length($to) < length($payload);
                warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
                $dispatch->{ $to }->( $rest );
        } else {
                print "NO DISPATCH for ",dump( $full ),"\n";
        }

        return $data;
}

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

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

        my $bytes = str2bytes( $cmd );

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

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

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

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

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

        readchunk;
}

1	dpavlin	1	#!/usr/bin/perl
2
3			use Device::SerialPort qw (:STAT);
4			use strict;
5			use warnings;
6
7			use Data::Dump qw/dump/;
8	dpavlin	2	use Carp qw/confess/;
9	dpavlin	19	use Getopt::Long;
10	dpavlin	29	use File::Slurp;
11	dpavlin	1
12	dpavlin	23	use IO::Socket::INET;
13
14	dpavlin	25	my $meteor_server = '192.168.1.13:4671';
15	dpavlin	26	my $meteor_fh;
16	dpavlin	23
17			sub meteor {
18	dpavlin	25	my @a = @_;
19			push @a, scalar localtime() if $a[0] =~ m{^info};
20
21	dpavlin	26	if ( ! defined $meteor_fh ) {
22	dpavlin	35	if ( $meteor_fh =
23			IO::Socket::INET->new(
24			PeerAddr => $meteor_server,
25			Timeout => 1,
26			)
27			) {
28			warn "# meteor connected to $meteor_server";
29			} else {
30			warn "can't connect to meteor $meteor_server: $!";
31			$meteor_fh = 0;
32			}
33	dpavlin	26	}
34
35	dpavlin	35	if ( $meteor_fh ) {
36			warn ">> meteor ",dump( @a );
37			print $meteor_fh "ADDMESSAGE test ",join('\|',@a),"\n"
38			}
39	dpavlin	23	}
40
41	dpavlin	43	my $listen_port = 9000; # pick something not in use
42			sub http_server {
43
44			my $server = IO::Socket::INET->new(
45			Proto => 'tcp',
46			LocalPort => $listen_port,
47			Listen => SOMAXCONN,
48			Reuse => 1
49			);
50
51			die "can't setup server" unless $server;
52
53			print "Server $0 accepting clients at http://localhost:$listen_port/\n";
54
55			sub static {
56			my ($client,$path) = @_;
57
58			$path = "www/$path";
59
60			return unless -e $path;
61
62			my $type = 'text/plain';
63			$type = 'text/html' if $path =~ m{\.htm};
64			$type = 'application/javascript' if $path =~ m{\.js};
65
66			print $client "HTTP/1.0 200 OK\r\nContent-Type: $type\r\n\r\n";
67			open(my $html, $path);
68			while(<$html>) {
69			print $client $_;
70			}
71			close($html);
72
73			return $path;
74			}
75
76			while (my $client = $server->accept()) {
77			$client->autoflush(1);
78			my $request = <$client>;
79
80			warn "<< $request\n";
81
82			if ($request =~ m{^GET (/.*) HTTP/1.[01]}) {
83			my $method = $1;
84			if ( my $path = static( $client,$1 ) ) {
85			warn ">> $path";
86			} elsif ( $method =~ m{/scan} ) {
87			print $client "HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\n\r\n";
88			my $tags = scan_for_tags();
89			print $client "tags: ",dump($tags);
90			my $json;
91			map { $json->{$_} = decode_tag($_) } keys %$tags;
92			print $client "decoded: ",dump( $json );
93			} else {
94			print $client "HTTP/1.0 404 Unkown method\r\n";
95			}
96			} else {
97			print $client "HTTP/1.0 500 No method\r\n";
98			}
99			close $client;
100			}
101
102			die "server died";
103			}
104
105	dpavlin	4	my $debug = 0;
106
107	dpavlin	19	my $device = "/dev/ttyUSB0";
108			my $baudrate = "19200";
109			my $databits = "8";
110			my $parity = "none";
111			my $stopbits = "1";
112			my $handshake = "none";
113
114	dpavlin	29	my $program_path = './program/';
115	dpavlin	34	my $secure_path = './secure/';
116	dpavlin	29
117	dpavlin	43	# http server
118			my $http_server = 1;
119
120	dpavlin	41	# 3M defaults: 8,4
121			my $max_rfid_block = 16;
122			my $read_blocks = 8;
123
124	dpavlin	1	my $response = {
125			'd500090400110a0500027250' => 'version?',
126			'd60007fe00000500c97b' => 'no tag in range',
127
128			'd6000ffe00000501e00401003123aa26941a' => 'tag #1',
129			'd6000ffe00000501e0040100017c0c388e2b' => 'rfid card',
130			'd6000ffe00000501e00401003123aa2875d4' => 'tag red-stripe',
131
132			'd60017fe00000502e00401003123aa26e0040100017c0c38cadb' => 'tag #1 + card',
133			'd60017fe00000502e00401003123aa26e00401003123aa283124' => 'tag #1 + tag red-stripe',
134			};
135
136	dpavlin	19	GetOptions(
137	dpavlin	22	'd\|debug+' => \$debug,
138	dpavlin	19	'device=s' => \$device,
139			'baudrate=i' => \$baudrate,
140			'databits=i' => \$databits,
141			'parity=s' => \$parity,
142			'stopbits=i' => \$stopbits,
143			'handshake=s' => \$handshake,
144	dpavlin	26	'meteor=s' => \$meteor_server,
145	dpavlin	19	) or die $!;
146
147	dpavlin	22	my $verbose = $debug > 0 ? $debug-- : 0;
148
149	dpavlin	1	=head1 NAME
150
151			3m-810 - support for 3M 810 RFID reader
152
153			=head1 SYNOPSIS
154
155	dpavlin	19	3m-810.pl --device /dev/ttyUSB0
156	dpavlin	1
157			=head1 DESCRIPTION
158
159			Communicate with 3M 810 RFID reader and document it's protocol
160
161			=head1 SEE ALSO
162
163			L<Device::SerialPort(3)>
164
165			L<perl(1)>
166
167	dpavlin	15	L<http://stackoverflow.com/questions/149617/how-could-i-guess-a-checksum-algorithm>
168
169	dpavlin	1	=head1 AUTHOR
170
171			Dobrica Pavlinusic <dpavlin@rot13.org> L<http://www.rot13.org/~dpavlin/>
172
173			=head1 COPYRIGHT AND LICENSE
174
175			This program is free software; you may redistribute it and/or modify
176			it under the same terms ans Perl itself.
177
178			=cut
179
180	dpavlin	23	my $tags_data;
181			my $visible_tags;
182
183	dpavlin	31	my $item_type = {
184			1 => 'Book',
185			6 => 'CD/CD ROM',
186			2 => 'Magazine',
187			13 => 'Book with Audio Tape',
188			9 => 'Book with CD/CD ROM',
189			0 => 'Other',
190
191			5 => 'Video',
192			4 => 'Audio Tape',
193			3 => 'Bound Journal',
194			8 => 'Book with Diskette',
195			7 => 'Diskette',
196			};
197
198			warn "## known item type: ",dump( $item_type ) if $debug;
199
200	dpavlin	19	my $port=new Device::SerialPort($device) \|\| die "can't open serial port $device: $!\n";
201			warn "using $device $handshake $baudrate $databits $parity $stopbits" if $debug;
202	dpavlin	1	$handshake=$port->handshake($handshake);
203			$baudrate=$port->baudrate($baudrate);
204			$databits=$port->databits($databits);
205			$parity=$port->parity($parity);
206			$stopbits=$port->stopbits($stopbits);
207
208	dpavlin	22	print "## using $device $baudrate $databits $parity $stopbits debug: $debug verbose: $verbose\n";
209	dpavlin	1
210			# Just in case: reset our timing and buffers
211			$port->lookclear();
212			$port->read_const_time(100);
213			$port->read_char_time(5);
214
215			# Turn on parity checking:
216			#$port->stty_inpck(1);
217			#$port->stty_istrip(1);
218
219	dpavlin	4	# initial hand-shake with device
220
221	dpavlin	20	cmd( 'D5 00 05 04 00 11 8C66', 'hw version',
222			'D5 00 09 04 00 11 0A 05 00 02 7250', sub {
223	dpavlin	23	my $hw_ver = join('.', unpack('CCCC', skip_assert(3) ));
224			print "hardware version $hw_ver\n";
225	dpavlin	25	meteor( 'info', "Found reader hardware $hw_ver" );
226	dpavlin	2	});
227	dpavlin	1
228	dpavlin	20	cmd( 'D6 00 0C 13 04 01 00 02 00 03 00 04 00 AAF2','FIXME: stats?',
229			'D6 00 0C 13 00 02 01 01 03 02 02 03 00 E778', sub { assert() } );
230	dpavlin	1
231	dpavlin	43	sub scan_for_tags {
232	dpavlin	1
233	dpavlin	43	my @tags;
234	dpavlin	20
235	dpavlin	43	cmd( 'D6 00 05 FE 00 05 FA40', "scan for tags, retry $_",
236			'D6 00 0F FE 00 00 05 ', sub { # 01 E00401003123AA26 941A # seen, serial length: 8
237			my $rest = shift \|\| die "no rest?";
238			my $nr = ord( substr( $rest, 0, 1 ) );
239	dpavlin	20
240	dpavlin	43	if ( ! $nr ) {
241			print "no tags in range\n";
242			update_visible_tags();
243			meteor( 'info-none-in-range' );
244			$tags_data = {};
245			} else {
246	dpavlin	1
247	dpavlin	43	my $tags = substr( $rest, 1 );
248	dpavlin	5
249	dpavlin	43	my $tl = length( $tags );
250			die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8;
251	dpavlin	16
252	dpavlin	43	push @tags, uc(unpack('H16', substr($tags, $_ * 8, 8))) foreach ( 0 .. $nr - 1 );
253			warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ) if $debug;
254			print "$nr tags in range: ", join(',', @tags ) , "\n";
255	dpavlin	25
256	dpavlin	43	meteor( 'info-in-range', join(' ',@tags));
257
258			update_visible_tags( @tags );
259			}
260	dpavlin	5	}
261	dpavlin	43	);
262	dpavlin	5
263	dpavlin	43	warn "## tags: ",dump( @tags );
264			return $tags_data;
265	dpavlin	22
266	dpavlin	43	}
267	dpavlin	22
268	dpavlin	43	# start scanning for tags
269
270			if ( $http_server ) {
271			http_server;
272			} else {
273			scan_for_tags while 1;
274			}
275
276			die "over and out";
277
278	dpavlin	22	sub update_visible_tags {
279			my @tags = @_;
280
281			my $last_visible_tags = $visible_tags;
282			$visible_tags = {};
283
284			foreach my $tag ( @tags ) {
285			if ( ! defined $last_visible_tags->{$tag} ) {
286	dpavlin	25	if ( defined $tags_data->{$tag} ) {
287			# meteor( 'in-range', $tag );
288			} else {
289			meteor( 'read', $tag );
290			read_tag( $tag );
291			}
292	dpavlin	22	$visible_tags->{$tag}++;
293			} else {
294			warn "## using cached data for $tag" if $debug;
295			}
296			delete $last_visible_tags->{$tag}; # leave just missing tags
297	dpavlin	29
298			if ( -e "$program_path/$tag" ) {
299			meteor( 'write', $tag );
300			write_tag( $tag );
301			}
302	dpavlin	34	if ( -e "$secure_path/$tag" ) {
303			meteor( 'secure', $tag );
304			secure_tag( $tag );
305			}
306	dpavlin	22	}
307
308			foreach my $tag ( keys %$last_visible_tags ) {
309	dpavlin	23	my $data = delete $tags_data->{$tag};
310			print "removed tag $tag with data ",dump( $data ),"\n";
311	dpavlin	25	meteor( 'removed', $tag );
312	dpavlin	22	}
313
314			warn "## update_visible_tags(",dump( @tags ),") = ",dump( $visible_tags )," removed: ",dump( $last_visible_tags ), " data: ",dump( $tags_data ) if $debug;
315			}
316
317	dpavlin	28	my $tag_data_block;
318	dpavlin	22
319	dpavlin	28	sub read_tag_data {
320			my ($start_block,$rest) = @_;
321			die "no rest?" unless $rest;
322	dpavlin	41
323			my $last_block = 0;
324
325	dpavlin	28	warn "## DATA [$start_block] ", dump( $rest ) if $debug;
326			my $tag = uc(unpack('H16',substr( $rest, 0, 8 )));
327			my $blocks = ord(substr($rest,8,1));
328			$rest = substr($rest,9); # leave just data blocks
329			foreach my $nr ( 0 .. $blocks - 1 ) {
330			my $block = substr( $rest, $nr * 6, 6 );
331			warn "## block ",as_hex( $block ) if $debug;
332			my $ord = unpack('v',substr( $block, 0, 2 ));
333			my $expected_ord = $nr + $start_block;
334	dpavlin	41	warn "got block $ord, expected block $expected_ord from ",dump( $block ) if $ord != $expected_ord;
335	dpavlin	28	my $data = substr( $block, 2 );
336			die "data payload should be 4 bytes" if length($data) != 4;
337	dpavlin	40	warn sprintf "## tag %9s %02d: %s \|%-4s\|\n", $tag, $ord, as_hex( $data ), $data;
338	dpavlin	28	$tag_data_block->{$tag}->[ $ord ] = $data;
339	dpavlin	41	$last_block = $ord;
340	dpavlin	28	}
341			$tags_data->{ $tag } = join('', @{ $tag_data_block->{$tag} });
342	dpavlin	31
343			my $item_type_nr = ord(substr( $tags_data->{$tag}, 3, 1 ));
344	dpavlin	42	print "DATA $tag ",dump( $tags_data ), " item type: ", ( $item_type->{ $item_type_nr } \|\| "UNKWOWN '$item_type_nr'" ), "\n";
345	dpavlin	41
346	dpavlin	42	return $last_block + 1;
347	dpavlin	28	}
348
349	dpavlin	43	sub decode_tag {
350			my $tag = shift;
351
352			my $data = $tags_data->{$tag} \|\| die "no data for $tag";
353
354			my ( $u1, $set_item, $u2, $type, $content, $br_lib, $custom ) = unpack('C4Z16Nl>',$data);
355			my $hash = {
356			u1 => $u1,
357			u2 => $u2,
358			set => ( $set_item & 0xf0 ) >> 4,
359			total => ( $set_item & 0x0f ),
360
361			type => $type,
362			content => $content,
363
364			branch => $br_lib >> 20,
365			library => $br_lib & 0x000fffff,
366
367			custom => $custom,
368			};
369
370			return $hash;
371			}
372
373	dpavlin	16	sub read_tag {
374			my ( $tag ) = @_;
375	dpavlin	1
376	dpavlin	22	confess "no tag?" unless $tag;
377
378	dpavlin	16	print "read_tag $tag\n";
379	dpavlin	1
380	dpavlin	41	my $start_block = 0;
381	dpavlin	28
382	dpavlin	41	while ( $start_block < $max_rfid_block ) {
383	dpavlin	1
384	dpavlin	41	cmd(
385			sprintf( "D6 00 0D 02 $tag %02x %02x ffff", $start_block, $read_blocks ),
386			"read $tag offset: $start_block blocks: $read_blocks",
387			"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";
388			$start_block = read_tag_data( $start_block, @_ );
389			warn "# read tag upto $start_block\n";
390			},
391			"D6 00 0F FE 00 00 05 01 $tag 941A", sub {
392			print "FIXME: tag $tag ready? (expected block read instead)\n";
393			},
394			);
395
396			}
397
398	dpavlin	33	my $security;
399
400			cmd(
401			"D6 00 0B 0A $tag 1234", "check security $tag",
402			"D6 00 0D 0A 00", sub {
403			my $rest = shift;
404			my $from_tag;
405			( $from_tag, $security ) = ( substr($rest,0,8), substr($rest,8,1) );
406			die "security from other tag: ",as_hex( $from_tag ) if $from_tag ne str2bytes( $tag );
407			$security = as_hex( $security );
408			warn "# SECURITY $tag = $security\n";
409			}
410			);
411
412	dpavlin	43	print "TAG $tag ", dump(decode_tag( $tag ));
413	dpavlin	16	}
414
415	dpavlin	29	sub write_tag {
416			my ($tag) = @_;
417
418			my $path = "$program_path/$tag";
419
420			my $data = read_file( $path );
421	dpavlin	38	my $hex_data;
422	dpavlin	29
423	dpavlin	38	if ( $data =~ s{^hex\s+}{} ) {
424			$hex_data = $data;
425			$hex_data =~ s{\s+}{}g;
426			} else {
427	dpavlin	29
428	dpavlin	38	$data .= "\0" x ( 4 - ( length($data) % 4 ) );
429	dpavlin	30
430	dpavlin	41	my $max_len = $max_rfid_block * 4;
431	dpavlin	30
432	dpavlin	38	if ( length($data) > $max_len ) {
433			$data = substr($data,0,$max_len);
434			warn "strip content to $max_len bytes\n";
435			}
436
437			$hex_data = unpack('H*', $data);
438			}
439
440			my $len = length($hex_data) / 2;
441	dpavlin	40	# pad to block size
442			$hex_data .= '00' x ( 4 - $len % 4 );
443			my $blocks = sprintf('%02x', length($hex_data) / 4);
444	dpavlin	38
445			print "write_tag $tag = ",dump( $data ), " [$len/$blocks] == $hex_data\n";
446
447	dpavlin	29	cmd(
448	dpavlin	38	"d6 00 ff 04 $tag 00 $blocks 00 $hex_data ffff", "write $tag",
449			"d6 00 0d 04 00 $tag $blocks afb1", sub { assert() },
450	dpavlin	40	); # foreach ( 1 .. 3 ); # XXX 3m software does this three times!
451	dpavlin	29
452			my $to = $path;
453			$to .= '.' . time();
454
455			rename $path, $to;
456			print ">> $to\n";
457
458	dpavlin	30	delete $tags_data->{$tag}; # force re-read of tag
459	dpavlin	29	}
460
461	dpavlin	34	sub secure_tag {
462			my ($tag) = @_;
463
464			my $path = "$secure_path/$tag";
465			my $data = substr(read_file( $path ),0,2);
466
467			cmd(
468			"d6 00 0c 09 $tag $data 1234", "secure $tag -> $data",
469			"d6 00 0c 09 00 $tag 1234", sub { assert() },
470			);
471
472			my $to = $path;
473			$to .= '.' . time();
474
475			rename $path, $to;
476			print ">> $to\n";
477			}
478
479	dpavlin	19	exit;
480
481	dpavlin	1	for ( 1 .. 3 ) {
482
483			# ++-->type 00-0a
484			# 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
485			# 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
486			# 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
487
488			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 $_" );
489			warn "D6 00 0D 04 00 E00401003123AA26 07 CFF1 -- ack 7 block?\n";
490
491			}
492			warn " D6 00 0F FE 00 00 05 01 E00401003123AA26 941A\n";
493
494			cmd( 'D6 00 05 FE 00 05 FA 40', "port-write scan $_" ) foreach ( 1 .. 2 );
495
496			cmd('D6 00 0C 09 E00401003123AA26 D7 3AF0', 'checkin?',
497			'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
498			cmd('D6 00 0C 09 E00401003123AA26 DA EB5D', 'checkout?',
499			'D6 00 0C 09 00 E00401003123AA26 6A44 -- no?' );
500
501			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',
502			'D6 00 0D 04 00 E00401003123AA26 06 DFD0 -- ack 6 blocks' ) foreach ( 1 .. 3 );
503
504			undef $port;
505			print "Port closed\n";
506
507			sub writechunk
508			{
509			my $str=shift;
510			my $count = $port->write($str);
511	dpavlin	38	my $len = length($str);
512			die "wrong write length $count != $len in ",as_hex( $str ) if $count != $len;
513	dpavlin	19	print "#> ", as_hex( $str ), "\t[$count]\n" if $debug;
514	dpavlin	1	}
515
516			sub as_hex {
517			my @out;
518			foreach my $str ( @_ ) {
519			my $hex = unpack( 'H*', $str );
520	dpavlin	2	$hex =~ s/(..)/$1 /g if length( $str ) > 2;
521	dpavlin	8	$hex =~ s/\s+$//;
522	dpavlin	1	push @out, $hex;
523			}
524	dpavlin	8	return join(' \| ', @out);
525	dpavlin	1	}
526
527			sub read_bytes {
528			my ( $len, $desc ) = @_;
529			my $data = '';
530			while ( length( $data ) < $len ) {
531			my ( $c, $b ) = $port->read(1);
532	dpavlin	28	die "no bytes on port: $!" unless defined $b;
533	dpavlin	1	#warn "## got $c bytes: ", as_hex($b), "\n";
534			$data .= $b;
535			}
536			$desc \|\|= '?';
537	dpavlin	4	warn "#< ", as_hex($data), "\t$desc\n" if $debug;
538	dpavlin	1	return $data;
539			}
540
541	dpavlin	5	our $assert;
542	dpavlin	2
543	dpavlin	5	# my $rest = skip_assert( 3 );
544			sub skip_assert {
545			assert( 0, shift );
546			}
547
548	dpavlin	2	sub assert {
549			my ( $from, $to ) = @_;
550
551	dpavlin	5	$from \|\|= 0;
552	dpavlin	4	$to = length( $assert->{expect} ) if ! defined $to;
553
554	dpavlin	2	my $p = substr( $assert->{payload}, $from, $to );
555			my $e = substr( $assert->{expect}, $from, $to );
556	dpavlin	3	warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p;
557	dpavlin	5
558			# return the rest
559			return substr( $assert->{payload}, $to );
560	dpavlin	2	}
561
562	dpavlin	15	use Digest::CRC;
563
564			sub crcccitt {
565			my $bytes = shift;
566			my $crc = Digest::CRC->new(
567			# midified CCITT to xor with 0xffff instead of 0x0000
568			width => 16, init => 0xffff, xorout => 0xffff, refout => 0, poly => 0x1021, refin => 0,
569			) or die $!;
570			$crc->add( $bytes );
571			pack('n', $crc->digest);
572			}
573
574	dpavlin	8	# my $checksum = checksum( $bytes );
575			# my $checksum = checksum( $bytes, $original_checksum );
576			sub checksum {
577			my ( $bytes, $checksum ) = @_;
578
579	dpavlin	16	my $len = ord(substr($bytes,2,1));
580	dpavlin	17	my $len_real = length($bytes) - 1;
581	dpavlin	16
582	dpavlin	17	if ( $len_real != $len ) {
583			print "length wrong: $len_real != $len\n";
584	dpavlin	38	$bytes = substr($bytes,0,2) . chr($len_real) . substr($bytes,3);
585	dpavlin	17	}
586
587	dpavlin	38	my $xor = crcccitt( substr($bytes,1) ); # skip D6
588			warn "## checksum ",dump( $bytes, $xor, $checksum ) if $debug;
589
590	dpavlin	8	if ( defined $checksum && $xor ne $checksum ) {
591	dpavlin	10	print "checksum doesn't match: ", as_hex($xor), " != ", as_hex($checksum), " data: ", as_hex($bytes), "\n";
592	dpavlin	16	return $bytes . $xor;
593	dpavlin	8	}
594	dpavlin	16	return $bytes . $checksum;
595	dpavlin	8	}
596
597	dpavlin	20	our $dispatch;
598
599	dpavlin	1	sub readchunk {
600	dpavlin	43	# sleep 1; # FIXME remove
601	dpavlin	2
602	dpavlin	1	# read header of packet
603			my $header = read_bytes( 2, 'header' );
604	dpavlin	2	my $length = read_bytes( 1, 'length' );
605			my $len = ord($length);
606	dpavlin	1	my $data = read_bytes( $len, 'data' );
607
608	dpavlin	2	my $payload = substr( $data, 0, -2 );
609			my $payload_len = length($data);
610			warn "## payload too short $payload_len != $len\n" if $payload_len != $len;
611	dpavlin	8
612	dpavlin	2	my $checksum = substr( $data, -2, 2 );
613	dpavlin	20	checksum( $header . $length . $payload , $checksum );
614	dpavlin	1
615	dpavlin	22	print "<< ",as_hex( $header ), " [$len] ", as_hex( $payload ), " \| sum: ",as_hex($checksum),"\n" if $verbose;
616	dpavlin	2
617			$assert->{len} = $len;
618			$assert->{payload} = $payload;
619
620	dpavlin	20	my $full = $header . $length . $data; # full
621			# find longest match for incomming data
622			my ($to) = grep {
623			my $match = substr($payload,0,length($_));
624			m/^\Q$match\E/
625			} sort { length($a) <=> length($b) } keys %$dispatch;
626			warn "?? payload dispatch to ",dump( $payload, $dispatch, $to ) if $debug;
627	dpavlin	2
628	dpavlin	42	if ( defined $to ) {
629			my $rest = substr( $payload, length($to) ) if length($to) < length($payload);
630	dpavlin	20	warn "## DISPATCH payload to with rest", dump( $payload, $to, $rest ) if $debug;
631			$dispatch->{ $to }->( $rest );
632			} else {
633			print "NO DISPATCH for ",dump( $full ),"\n";
634			}
635
636	dpavlin	2	return $data;
637	dpavlin	1	}
638
639	dpavlin	2	sub str2bytes {
640			my $str = shift \|\| confess "no str?";
641	dpavlin	5	my $b = $str;
642	dpavlin	17	$b =~ s/\s+//g;
643			$b =~ s/(..)/\\x$1/g;
644			$b = "\"$b\"";
645	dpavlin	5	my $bytes = eval $b;
646	dpavlin	2	die $@ if $@;
647	dpavlin	5	warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug;
648	dpavlin	2	return $bytes;
649			}
650
651			sub cmd {
652	dpavlin	20	my $cmd = shift \|\| confess "no cmd?";
653			my $cmd_desc = shift \|\| confess "no description?";
654			my @expect = @_;
655
656	dpavlin	2	my $bytes = str2bytes( $cmd );
657
658	dpavlin	16	# fix checksum if needed
659			$bytes = checksum( substr( $bytes, 0, -2 ), substr( $bytes, -2, 2 ) );
660
661	dpavlin	22	warn ">> ", as_hex( $bytes ), "\t## $cmd_desc\n" if $verbose;
662	dpavlin	2	$assert->{send} = $cmd;
663			writechunk( $bytes );
664
665	dpavlin	20	while ( @expect ) {
666			my $pattern = str2bytes( shift @expect ) \|\| confess "no pattern?";
667			my $coderef = shift @expect \|\| confess "no coderef?";
668			confess "not coderef" unless ref $coderef eq 'CODE';
669
670			next if defined $dispatch->{ $pattern };
671
672			$dispatch->{ substr($pattern,3) } = $coderef;
673			warn "++ dispatch ", as_hex($pattern) ,dump( $dispatch ) if $debug;
674	dpavlin	2	}
675	dpavlin	20
676			readchunk;
677	dpavlin	2	}
678