81 |
|
|
82 |
cmd( 'D5 00 05 04 00 11 8C66', 'hw version?', |
cmd( 'D5 00 05 04 00 11 8C66', 'hw version?', |
83 |
'D5 00 09 04 00 11 0A 05 00 02 7250', 'hw 10.5.0.2', sub { |
'D5 00 09 04 00 11 0A 05 00 02 7250', 'hw 10.5.0.2', sub { |
84 |
my ( $len, $payload, $checksum ) = @_; |
print "hardware version ", join('.', unpack('CCCC', skip_assert(3) )), "\n"; |
|
assert( 0, 3 ); |
|
|
print "hardware version ", join('.', unpack('CCCC', substr($payload,3,4))), "\n"; |
|
85 |
}); |
}); |
86 |
|
|
87 |
cmd( 'D6 00 0C 13 04 01 00 02 00 03 00 04 00 AAF2','stats?', |
cmd( 'D6 00 0C 13 04 01 00 02 00 03 00 04 00 AAF2','stats?', |
88 |
'D6 00 0C 13 00 02 01 01 03 02 02 03 00 E778','FIXME: unimplemented', sub { assert( 0 ) } ); |
'D6 00 0C 13 00 02 01 01 03 02 02 03 00 E778','FIXME: unimplemented', sub { assert() } ); |
89 |
|
|
90 |
# start scanning for tags |
# start scanning for tags |
91 |
|
|
92 |
cmd( 'D6 00 05 FE 00 05 FA40', "XXX scan $_", |
cmd( 'D6 00 05 FE 00 05 FA40', "XXX scan $_", |
93 |
'D6 00 07 FE 00 00 05 00 C97B', 'no tag' ) foreach ( 1 .. 10 ); |
'D6 00 07 FE 00 00 05 00 C97B', 'no tag', sub { |
94 |
# D6 00 0F FE 00 00 05 01 E00401003123AA26 941A # seen |
dispatch( |
95 |
|
'D6 00 0F FE 00 00 05 ',# 01 E00401003123AA26 941A # seen, serial length: 8 |
96 |
|
sub { |
97 |
|
my $rest = shift || die "no rest?"; |
98 |
|
my $nr = ord( substr( $rest, 0, 1 ) ); |
99 |
|
my $tags = substr( $rest, 1 ); |
100 |
|
|
101 |
|
my $tl = length( $tags ); |
102 |
|
die "wrong length $tl for $nr tags: ",dump( $tags ) if $tl =! $nr * 8; |
103 |
|
|
104 |
|
my @tags; |
105 |
|
push @tags, substr($tags, $_ * 8, 8) foreach ( 0 .. $nr - 1 ); |
106 |
|
warn "## tags ",as_hex($tags), " [$tl] = ",dump( $tags ); |
107 |
|
print "seen $nr tags: ", join(',', map { unpack('H16', $_) } @tags ) , "\n"; |
108 |
|
} |
109 |
|
) } |
110 |
|
|
111 |
|
) foreach ( 1 .. 100 ); |
112 |
|
|
113 |
cmd( 'D6 00 0D 02 E00401003123AA26 00 03 1CC4', 'read offset: 0 blocks: 3' ); |
cmd( 'D6 00 0D 02 E00401003123AA26 00 03 1CC4', 'read offset: 0 blocks: 3' ); |
114 |
|
|
153 |
{ |
{ |
154 |
my $str=shift; |
my $str=shift; |
155 |
my $count = $port->write($str); |
my $count = $port->write($str); |
156 |
print ">> ", as_hex( $str ), "\t[$count]\n"; |
print "#> ", as_hex( $str ), "\t[$count]\n"; |
157 |
} |
} |
158 |
|
|
159 |
sub as_hex { |
sub as_hex { |
179 |
return $data; |
return $data; |
180 |
} |
} |
181 |
|
|
182 |
my $assert; |
our $assert; |
183 |
|
|
184 |
|
# my $rest = skip_assert( 3 ); |
185 |
|
sub skip_assert { |
186 |
|
assert( 0, shift ); |
187 |
|
} |
188 |
|
|
189 |
sub assert { |
sub assert { |
190 |
my ( $from, $to ) = @_; |
my ( $from, $to ) = @_; |
191 |
|
|
192 |
|
$from ||= 0; |
193 |
$to = length( $assert->{expect} ) if ! defined $to; |
$to = length( $assert->{expect} ) if ! defined $to; |
194 |
|
|
195 |
my $p = substr( $assert->{payload}, $from, $to ); |
my $p = substr( $assert->{payload}, $from, $to ); |
196 |
my $e = substr( $assert->{expect}, $from, $to ); |
my $e = substr( $assert->{expect}, $from, $to ); |
197 |
warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p; |
warn "EXPECTED ",as_hex($e), " GOT ", as_hex($p), " [$from-$to] in ",dump( $assert ), "\n" if $e ne $p; |
198 |
|
|
199 |
|
# return the rest |
200 |
|
return substr( $assert->{payload}, $to ); |
201 |
|
} |
202 |
|
|
203 |
|
our $dispatch; |
204 |
|
sub dispatch { |
205 |
|
my ( $pattern, $coderef ) = @_; |
206 |
|
my $patt = substr( str2bytes($pattern), 3 ); # just payload |
207 |
|
my $l = length($patt); |
208 |
|
my $p = substr( $assert->{payload}, 0, $l ); |
209 |
|
warn "## dispatch pattern $pattern [$l] ",dump( $patt, $p ) if $debug; |
210 |
|
|
211 |
|
if ( $assert->{payload} eq $assert->{expect} ) { |
212 |
|
warn "## no dispatch, payload expected" if $debug; |
213 |
|
} elsif ( $p eq $patt ) { |
214 |
|
# if matched call with rest of payload |
215 |
|
$coderef->( substr( $assert->{payload}, $l ) ); |
216 |
|
} else { |
217 |
|
warn "## dispatch ignored" if $debug; |
218 |
|
} |
219 |
} |
} |
220 |
|
|
221 |
sub readchunk { |
sub readchunk { |
249 |
|
|
250 |
sub str2bytes { |
sub str2bytes { |
251 |
my $str = shift || confess "no str?"; |
my $str = shift || confess "no str?"; |
252 |
$str =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/; # fix checksum |
my $b = $str; |
253 |
$str =~ s/\s+/\\x/g; |
$b =~ s/\s+(\S\S)(\S\S)+\s*/ $1 $2/; # fix checksum |
254 |
$str = '"\x' . $str . '"'; |
$b =~ s/\s+$//; |
255 |
my $bytes = eval $str; |
$b =~ s/\s+/\\x/g; |
256 |
|
$b = '"\x' . $b . '"'; |
257 |
|
my $bytes = eval $b; |
258 |
die $@ if $@; |
die $@ if $@; |
259 |
|
warn "## str2bytes( $str ) => $b => ",as_hex($bytes) if $debug; |
260 |
return $bytes; |
return $bytes; |
261 |
} |
} |
262 |
|
|