require
5.8.0;
our
$VERSION
=
'0.16'
;
my
$_debug
= 0;
my
$_error
= 0;
share(
$_debug
);
share(
$_error
);
sub
_dbg($$) {
my
$self
=
shift
;
my
$line
=
shift
;
my
$debug
=
shift
;
return
if
(!
$self
->{
'debug'
});
$debug
= 0
if
(!
$debug
);
return
if
(
$self
->{
'debug'
} <
$debug
);
my
$pfx
=
$self
->{
'debug_prefix'
};
$pfx
=
'eio'
if
(!
$pfx
);
$pfx
.=
':'
.threads->self->tid()
if
(
$self
->{
'threaded'
});
print
STDERR
$pfx
.
': '
.
$line
.
"\n"
;
}
sub
new {
my
$proto
=
shift
;
my
%arg
=
@_
;
my
$class
=
ref
(
$proto
) ||
$proto
;
my
$self
= {};
return
0
if
(!
$arg
{
'target_addr'
});
$self
->{
'socket'
} = IO::Socket::INET->new(
PeerAddr
=>
$arg
{
'target_addr'
},
PeerPort
=>
$arg
{
'target_port'
} ||
'2424'
,
Proto
=>
'udp'
,
ReuseAddr
=> 1,
);
if
(!
$self
->{
'socket'
}) {
$_error
=
"Net::Elexol::EtherIO24->new can't create socket: $@\n"
;
return
undef
;
}
$self
->{
'debug'
} =
$_debug
;
$self
->{
'debug_prefix'
} =
'eio24'
;
$self
->{
'prefetch_status'
} = 1;
$self
->{
'presend_status'
} = 0;
$self
->{
'threaded'
} = 0;
$self
->{
'recv_timeout'
} = 1.0;
$self
->{
'service_recv_timeout'
} = 1.0;
$self
->{
'service_status_fetch'
} = 60;
$self
->{
'direct_writes'
} = 1;
$self
->{
'direct_reads'
} = 1;
$self
->{
'indirect_write_interval'
} = 0.1;
$self
->{
'indirect_read_interval'
} = 0.5;
$self
->{
'read_before_write'
} = 0;
foreach
my
$field
((
'debug'
,
'debug_prefix'
,
'prefetch_status'
,
'presend_status'
,
'threaded'
,
'recv_timeout'
,
'service_recv_timeout'
,
'service_status_fetch'
,
'direct_writes'
,
'direct_reads'
,
'indirect_write_interval'
,
'indirect_read_interval'
,
'read_before_write'
, )) {
$self
->{
$field
} =
$arg
{
$field
}
if
(
defined
(
$arg
{
$field
}));
}
bless
(
$self
,
$class
);
$self
->{
'data'
} = {};
if
(
$arg
{
'data'
}) {
$self
->{
'data'
} =
$arg
{
'data'
};
}
_init_state(
$self
);
if
(
$self
->{
'threaded'
}) {
$self
->_dbg(
"we're going to be using threads, starting service threads..."
, 1);
$self
->{
'thread_indirect'
} = threads->new(\
&_service_indirect
,
$self
);
$self
->{
'thread_status'
} = threads->new(\
&_service_status
,
$self
);
$self
->{
'thread_recv'
} = threads->new(\
&_service_recv
,
$self
);
}
if
(
$self
->{
'prefetch_status'
}) {
if
(!
$self
->status_fetch) {
$self
->
close
;
$_error
.=
' while prefetching status'
;
return
undef
;
}
if
(!
$self
->eeprom_fetch) {
$self
->
close
;
$_error
.=
' while prefetching eeprom contents'
;
return
undef
;
}
}
$self
->status_send()
if
(
$self
->{
'presend_status'
});
return
$self
;
}
DESTROY {
my
$self
=
shift
;
$self
->
close
;
}
sub
close
{
my
$self
=
shift
;
return
if
(!
$self
->{
'data'
}->{
'running'
});
$self
->indirect_write_send;
$self
->{
'data'
}->{
'running'
} = 0;
$self
->{
'socket'
}->
close
if
(
$self
->{
'socket'
});
if
(
$self
->{
'threaded'
}) {
foreach
my
$tname
((
'indirect'
,
'status'
,
'recv'
)) {
$self
->_dbg(
"waiting for service '$tname' thread to die"
, 1);
my
$t
=
$self
->{
'thread_'
.
$tname
};
$t
->
join
if
(
$t
);
$self
->{
'thread_'
.
$tname
} =
undef
;
}
}
}
sub
_service_indirect {
my
$self
=
shift
;
$self
->_dbg(
"service_indirect starting up"
, 1);
my
$indirect_time
= Time::HiRes::
time
() +
$self
->{
'indirect_write_interval'
};
while
(
$self
->{
'data'
}->{
'running'
}) {
if
(
$self
->{
'indirect_write_interval'
} &&
$indirect_time
< Time::HiRes::
time
()) {
$indirect_time
= Time::HiRes::
time
() +
$self
->{
'indirect_write_interval'
};
$self
->indirect_write_send;
}
else
{
Time::HiRes::usleep(1000000);
}
}
$self
->_dbg(
"service_indirect shutting down"
, 1);
}
sub
_service_status {
my
$self
=
shift
;
$self
->_dbg(
"service_status starting up"
, 1);
my
$status_time
= Time::HiRes::
time
() +
$self
->{
'service_status_fetch'
};
while
(
$self
->{
'data'
}->{
'running'
}) {
if
(
$self
->{
'service_status_fetch'
} &&
$status_time
< Time::HiRes::
time
()) {
$status_time
= Time::HiRes::
time
() +
$self
->{
'service_status_fetch'
};
$self
->status_fetch(0);
}
else
{
Time::HiRes::usleep(1000000);
}
}
$self
->_dbg(
"service_status shutting down"
, 1);
}
sub
_service_recv {
my
$self
=
shift
;
$self
->_dbg(
"service_recv starting up"
, 1);
while
(
$self
->{
'data'
}->{
'running'
}) {
$self
->recv_command;
}
$self
->_dbg(
"service_recv shutting down"
, 1);
}
sub
debug {
my
$self
=
shift
;
if
(
@_
) {
$_debug
=
shift
;
$self
->{
'debug'
} =
$_debug
if
(
ref
(
$self
));
}
return
$_debug
;
}
sub
error {
my
$self
=
shift
;
return
$_error
;
}
sub
dump_packet {
my
$self
=
shift
;
my
$packet
=
shift
;
my
$offset
=
shift
;
my
$incr
=
shift
;
my
$string
=
""
;
$offset
= 0
if
(!
defined
(
$offset
));
$incr
= 16
if
(!
defined
(
$incr
));
while
(
$offset
<
length
(
$packet
)) {
my
$l
=
substr
(
$packet
,
$offset
,
$incr
);
my
$hexstr
=
join
(
' '
,
map
{
sprintf
"%02.2x"
,
$_
}
unpack
(
"C*"
,
$l
));
my
$ascstr
=
$l
;
$ascstr
=~ s/\W/./g;
my
$hexlen
= (
$incr
*3)-1;
$string
.=
sprintf
(
"%04.4d %-${hexlen}.${hexlen}s %s\n"
,
$offset
,
$hexstr
,
$ascstr
);
$offset
+=
$incr
;
}
return
$string
;
}
sub
_dbg_packet {
my
$self
=
shift
;
my
$packet
=
shift
;
my
$debug
=
shift
;
my
$offset
=
shift
;
my
$incr
=
shift
;
return
if
(
$self
->{
'debug'
} <
$debug
);
my
$string
=
$self
->dump_packet(
$packet
,
$offset
,
$incr
);
foreach
my
$line
(
split
(/\n/,
$string
)) {
$self
->_dbg(
$line
,
$debug
);
}
}
my
$status_commands
= {
'status A'
=>
'a'
,
'status B'
=>
'b'
,
'status C'
=>
'c'
,
'dir A'
=>
'!a'
,
'dir B'
=>
'!b'
,
'dir C'
=>
'!c'
,
'pullup A'
=>
'@a'
,
'pullup B'
=>
'@b'
,
'pullup C'
=>
'@c'
,
'thresh A'
=>
'#a'
,
'thresh B'
=>
'#b'
,
'thresh C'
=>
'#c'
,
'schmitt A'
=>
'$a'
,
'schmitt B'
=>
'$b'
,
'schmitt C'
=>
'$c'
,
};
my
$status_map
= {};
foreach
my
$key
(
keys
%$status_commands
) {
$status_map
->{
$status_commands
->{
$key
}} =
$key
;
}
my
$set_commands
= {
'status A'
=>
'A'
,
'status B'
=>
'B'
,
'status C'
=>
'C'
,
'dir A'
=>
'!A'
,
'dir B'
=>
'!B'
,
'dir C'
=>
'!C'
,
'pullup A'
=>
'@A'
,
'pullup B'
=>
'@B'
,
'pullup C'
=>
'@C'
,
'thresh A'
=>
'#A'
,
'thresh B'
=>
'#B'
,
'thresh C'
=>
'#C'
,
'schmitt A'
=>
'$A'
,
'schmitt B'
=>
'$B'
,
'schmitt C'
=>
'$C'
,
};
my
$set_map
= {};
foreach
my
$key
(
keys
%$set_commands
) {
$set_map
->{
$set_commands
->{
$key
}} =
$key
;
}
my
$cmd_map
= {
'a'
=>
'A'
,
'!a'
=>
'!A'
,
'@a'
=>
'@A'
,
'#a'
=>
'#A'
,
'$a'
=>
'$A'
,
'b'
=>
'B'
,
'!b'
=>
'!B'
,
'@b'
=>
'@B'
,
'#b'
=>
'#B'
,
'$b'
=>
'$B'
,
'c'
=>
'C'
,
'!c'
=>
'!C'
,
'@c'
=>
'@C'
,
'#c'
=>
'#C'
,
'$c'
=>
'$C'
,
'IO24'
=>
'IO24'
,
'%'
=>
'%'
,
'`'
=>
'\''
,
'*'
=>
' '
,
'\'R'
=>
'R'
,
};
my
$cmd_rev_map
= {};
foreach
my
$key
(
keys
%$cmd_map
) {
$cmd_rev_map
->{
$cmd_map
->{
$key
}} =
$key
;
}
my
$send_commands
= {
'IO24'
=> {
length
=> 4,
'desc'
=>
'ID units'
,
},
'A'
=> {
'length'
=> 2,
'desc'
=>
'Wr Port A'
,
'type'
=>
'hex_byte'
,
},
'B'
=> {
'length'
=> 2,
'desc'
=>
'Wr Port C'
,
'type'
=>
'hex_byte'
,
},
'C'
=> {
'length'
=> 2,
'desc'
=>
'Wr Port C'
,
'type'
=>
'hex_byte'
,
},
'a'
=> {
'length'
=> 1,
'desc'
=>
'Rd Port A'
,
},
'b'
=> {
'length'
=> 1,
'desc'
=>
'Rd Port B'
,
},
'c'
=> {
'length'
=> 1,
'desc'
=>
'Rd Port C'
,
},
'!A'
=> {
'length'
=> 3,
'desc'
=>
'Wr Dir A'
,
'type'
=>
'hex_byte'
,
},
'!B'
=> {
'length'
=> 3,
'desc'
=>
'Wr Dir B'
,
'type'
=>
'hex_byte'
,
},
'!C'
=> {
'length'
=> 3,
'desc'
=>
'Wr Dir C'
,
'type'
=>
'hex_byte'
,
},
'!a'
=> {
'length'
=> 2,
'desc'
=>
'Rd Dir A'
,
},
'!b'
=> {
'length'
=> 2,
'desc'
=>
'Rd Dir B'
,
},
'!c'
=> {
'length'
=> 2,
'desc'
=>
'Rd Dir C'
,
},
'@A'
=> {
'length'
=> 3,
'desc'
=>
'Wr Pullup A'
,
'type'
=>
'hex_byte'
,
},
'@B'
=> {
'length'
=> 3,
'desc'
=>
'Wr Pullup B'
,
'type'
=>
'hex_byte'
,
},
'@C'
=> {
'length'
=> 3,
'desc'
=>
'Wr Pullup C'
,
'type'
=>
'hex_byte'
,
},
'#A'
=> {
'length'
=> 3,
'desc'
=>
'Wr Thresh A'
,
'type'
=>
'hex_byte'
,
},
'#B'
=> {
'length'
=> 3,
'desc'
=>
'Wr Thresh B'
,
'type'
=>
'hex_byte'
,
},
'#C'
=> {
'length'
=> 3,
'desc'
=>
'Wr Thresh C'
,
'type'
=>
'hex_byte'
,
},
'$A'
=> {
'length'
=> 3,
'desc'
=>
'Wr Schmitt A'
,
'type'
=>
'hex_byte'
,
},
'$B'
=> {
'length'
=> 3,
'desc'
=>
'Wr Schmitt B'
,
'type'
=>
'hex_byte'
,
},
'$C'
=> {
'length'
=> 3,
'desc'
=>
'Wr Schmitt C'
,
'type'
=>
'hex_byte'
,
},
'@a'
=> {
'length'
=> 2,
'desc'
=>
'Rd Pullup a'
,
},
'@b'
=> {
'length'
=> 2,
'desc'
=>
'Rd Pullup b'
,
},
'@c'
=> {
'length'
=> 2,
'desc'
=>
'Rd Pullup c'
,
},
'#a'
=> {
'length'
=> 2,
'desc'
=>
'Rd Thresh a'
,
},
'#b'
=> {
'length'
=> 2,
'desc'
=>
'Rd Thresh b'
,
},
'#c'
=> {
'length'
=> 2,
'desc'
=>
'Rd Thresh c'
,
},
'$a'
=> {
'length'
=> 2,
'desc'
=>
'Rd Schmitt a'
,
},
'$b'
=> {
'length'
=> 2,
'desc'
=>
'Rd Schmitt b'
,
},
'$c'
=> {
'length'
=> 2,
'desc'
=>
'Rd Schmitt c'
,
},
'\'R'
=> {
'length'
=> 5,
'desc'
=>
'Rd EEPROM word'
,
'type'
=>
'eeprom'
,
'nobundle'
=> 1,
},
'\'W'
=> {
'length'
=> 5,
'desc'
=>
'Wr EEPROM word'
,
'type'
=>
'eeprom'
,
'nobundle'
=> 1,
},
'\'E'
=> {
'length'
=> 5,
'desc'
=>
'Erase EEPROM word'
,
'type'
=>
'eeprom'
,
'nobundle'
=> 1,
},
'\'0'
=> {
'length'
=> 5,
'desc'
=>
'Write disable EEPROM'
,
'type'
=>
'eeprom'
,
'nobundle'
=> 1,
},
'\'1'
=> {
'length'
=> 5,
'desc'
=>
'Write enable EEPROM'
,
'type'
=>
'eeprom'
,
'nobundle'
=> 1,
},
'\'@'
=> {
'length'
=> 5,
'desc'
=>
'Reset module'
,
'type'
=>
'eeprom'
,
'nobundle'
=> 1,
},
'`'
=> {
'length'
=> 2,
'desc'
=>
'Echo byte'
,
'type'
=>
'hex_byte'
,
},
'*'
=> {
'length'
=> 1,
'desc'
=>
'Echo a space'
,
},
'%'
=> {
'length'
=> 1,
'desc'
=>
'Read host data'
,
},
};
my
$recv_commands
= {
'IO24'
=> {
length
=> 12,
'desc'
=>
'ID units'
,
'type'
=>
'io24'
,
},
'A'
=> {
'length'
=> 2,
'desc'
=>
'Wr Port A'
,
'type'
=>
'hex_byte'
,
},
'B'
=> {
'length'
=> 2,
'desc'
=>
'Wr Port C'
,
'type'
=>
'hex_byte'
,
},
'C'
=> {
'length'
=> 2,
'desc'
=>
'Wr Port C'
,
'type'
=>
'hex_byte'
,
},
'!A'
=> {
'length'
=> 3,
'desc'
=>
'Wr Dir A'
,
'type'
=>
'hex_byte'
,
},
'!B'
=> {
'length'
=> 3,
'desc'
=>
'Wr Dir B'
,
'type'
=>
'hex_byte'
,
},
'!C'
=> {
'length'
=> 3,
'desc'
=>
'Wr Dir C'
,
'type'
=>
'hex_byte'
,
},
'@A'
=> {
'length'
=> 3,
'desc'
=>
'Wr Pullup A'
,
'type'
=>
'hex_byte'
,
},
'@B'
=> {
'length'
=> 3,
'desc'
=>
'Wr Pullup B'
,
'type'
=>
'hex_byte'
,
},
'@C'
=> {
'length'
=> 3,
'desc'
=>
'Wr Pullup C'
,
'type'
=>
'hex_byte'
,
},
'#A'
=> {
'length'
=> 3,
'desc'
=>
'Wr Thresh A'
,
'type'
=>
'hex_byte'
,
},
'#B'
=> {
'length'
=> 3,
'desc'
=>
'Wr Thresh B'
,
'type'
=>
'hex_byte'
,
},
'#C'
=> {
'length'
=> 3,
'desc'
=>
'Wr Thresh C'
,
'type'
=>
'hex_byte'
,
},
'$A'
=> {
'length'
=> 3,
'desc'
=>
'Wr Schmitt A'
,
'type'
=>
'hex_byte'
,
},
'$B'
=> {
'length'
=> 3,
'desc'
=>
'Wr Schmitt B'
,
'type'
=>
'hex_byte'
,
},
'$C'
=> {
'length'
=> 3,
'desc'
=>
'Wr Schmitt C'
,
'type'
=>
'hex_byte'
,
},
'R'
=> {
'length'
=> 4,
'desc'
=>
'Rd EEPROM word'
,
'type'
=>
'eeprom_recv'
,
},
'\''
=> {
'length'
=> 2,
'desc'
=>
'Echo byte'
,
'type'
=>
'hex_byte'
,
},
' '
=> {
'length'
=> 1,
'desc'
=>
'Echo a space'
,
},
'%'
=> {
'length'
=> 16,
'desc'
=>
'Read host data'
,
'type'
=>
'host_data'
,
},
};
sub
_init_state {
my
$self
=
shift
;
my
$data
=
$self
->{
'data'
};
$data
->{
'running'
} = 1;
share(
$data
->{
'running'
});
foreach
my
$key
(
keys
%$status_commands
) {
$data
->{
$key
} = 0;
share(
$data
->{
$key
});
$data
->{
'changed '
.
$key
} = 0;
share(
$data
->{
'changed '
.
$key
});
$data
->{
'ts '
.
$key
} = 0;
share(
$data
->{
'ts '
.
$key
});
}
foreach
my
$addr
(0..63) {
$data
->{
'rcvd eeprom '
.
$addr
} = 0;
share(
$data
->{
'rcvd eeprom '
.
$addr
});
$data
->{
'eeprom '
.
$addr
} = 0;
share(
$data
->{
'eeprom '
.
$addr
});
}
foreach
my
$cmd
(
keys
%$cmd_map
) {
$data
->{
'rcvd '
.
$cmd_map
->{
$cmd
}} = 1;
share(
$data
->{
'rcvd '
.
$cmd_map
->{
$cmd
}});
$data
->{
'rcvdcmd '
.
$cmd_map
->{
$cmd
}} = 0;
share(
$data
->{
'rcvdcmd '
.
$cmd_map
->{
$cmd
}});
}
foreach
my
$var
((
'last_status_fetch'
,
'last_status_send'
,
'last_eeprom_fetch'
)) {
$data
->{
$var
} = 0;
share(
$data
->{
$var
});
}
}
sub
eeprom_fetch {
my
$self
=
shift
;
my
$recv
=
shift
|| 1;
my
$fetchall
=
shift
|| 0;
my
$last
= 24;
$last
= 63
if
(
$fetchall
);
foreach
my
$addr
(0..24) {
my
$cmd
=
"'R"
.
pack
(
"CCC"
,
$addr
, 0, 0);
if
(!send_command(
$self
,
$cmd
)) {
$self
->_dbg(
"WARNING: Unable to send eeprom request."
, 0);
return
0;
}
else
{
if
(
$recv
&& !recv_result(
$self
,
$cmd
)) {
$self
->_dbg(
"WARNING: Timeout waiting for eeprom reply."
, 0);
return
0;
}
}
}
$self
->{
'data'
}->{
'last_eeprom_fetch'
} =
time
();
return
1;
}
sub
status_fetch {
my
$self
=
shift
;
my
$recv
=
shift
;
my
$cmd
;
foreach
my
$key
(
sort
keys
%$status_commands
) {
$cmd
.=
$status_commands
->{
$key
};
}
if
(!send_command(
$self
,
$cmd
)) {
_dbg(
"WARNING: Unable to send status request."
, 0);
return
0;
}
else
{
if
(
$recv
&& !recv_result(
$self
,
$cmd
)) {
$self
->_dbg(
"WARNING: Error receiving status reply ($_error)"
, 0);
return
0;
}
}
$self
->{
'data'
}->{
'last_status_fetch'
} =
time
();
return
1;
}
sub
status_send {
my
$self
=
shift
;
my
$cmd
=
''
;
foreach
my
$key
(
sort
keys
%$set_commands
) {
$cmd
.=
$set_commands
->{
$key
}.
pack
(
"C"
,
$self
->{
$key
});
}
if
(!send_command(
$self
,
$cmd
)) {
$self
->_dbg(
"WARNING: Unable to send status.\n"
, 0);
return
0;
}
$self
->{
'data'
}->{
'last_status_send'
} =
time
();
}
sub
indirect_write_send {
my
$self
=
shift
;
my
$data
=
$self
->{
'data'
};
$self
->_dbg(
"indirect_write_send: checking for pending writes"
, 5);
foreach
my
$key
(
sort
keys
%$status_commands
) {
if
(
$data
->{
'changed '
.
$key
}) {
$self
->_dbg(
"indirect_write_send: \"$key\" is pending write..."
, 4);
send_command(
$self
,
$set_commands
->{
$key
}.
pack
(
"C"
,
$data
->{
$key
}));
$data
->{
'changed '
.
$key
} = 0;
}
}
}
sub
_decode_cmd {
my
$cmd
=
shift
;
my
$len
=
shift
;
my
$type
=
shift
;
my
$txt
=
''
;
$type
= 0
if
(!
$type
);
if
(
$type
eq
'hex_byte'
) {
foreach
my
$i
(
$len
..
length
(
$cmd
)-1) {
$txt
.=
sprintf
(
"%02.2x "
,
unpack
(
"x$i C1"
,
$cmd
));
}
}
elsif
(
$type
eq
'eeprom'
) {
my
(
$addr
,
$msb
,
$lsb
) =
unpack
(
"x2 CCC"
,
$cmd
);
$txt
=
sprintf
(
"addr: %d (%02.2x) val: %02.2x %02.2x"
,
$addr
,
$addr
,
$msb
,
$lsb
);
}
elsif
(
$type
eq
'eeprom_recv'
) {
my
(
$addr
,
$msb
,
$lsb
) =
unpack
(
"x CCC"
,
$cmd
);
$txt
=
sprintf
(
"addr: %d (%02.2x) val: %02.2x %02.2x"
,
$addr
,
$addr
,
$msb
,
$lsb
);
}
elsif
(
$type
eq
'host_data'
) {
$txt
.=
sprintf
(
"Serial: %02.2x%02.2x%02.2x "
.
"IP: %d.%d.%d.%d "
.
"MAC: %02.2x:%02.2x:%02.2x:%02.2x:%02.2x:%02.2x"
,
unpack
(
"x$len CCCCCCCCCCCCC"
,
$cmd
));
}
elsif
(
$type
eq
'io24'
) {
$txt
.=
sprintf
(
"MAC: %02.2x:%02.2x:02.2x:02.2x:02.2x:02.2x "
.
"Fw: %02.2x.$02.2x"
,
unpack
(
"x$len CCCCCCCC"
,
$cmd
));
}
return
$txt
;
}
sub
_find_cmd {
my
$cmd
=
shift
;
my
$cmds
=
shift
;
foreach
my
$len
(1..
length
(
$cmd
)) {
my
$c
=
substr
(
$cmd
, 0,
$len
);
if
(
$cmds
->{
$c
}) {
return
$c
;
}
}
return
0;
}
sub
verify_send_command {
my
$self
=
shift
;
my
$cmd
=
shift
;
my
$data
=
$self
->{
'data'
};
my
$start
= 0;
my
$ok
= 1;
while
(
$start
<
length
(
$cmd
) &&
$ok
) {
my
$c
= _find_cmd(
substr
(
$cmd
,
$start
, 6),
$send_commands
);
if
(
$c
) {
my
$len
=
length
(
$c
);
my
$chk
=
substr
(
$cmd
,
$start
,
$send_commands
->{
$c
}->{
'length'
});
if
(
$self
->{
'debug'
}>1) {
my
$type
=
$send_commands
->{
$c
}->{
'type'
};
my
$txt
= _decode_cmd(
$chk
,
$len
,
$type
);
$self
->_dbg(
"verify_send_command: cmd \"$c\" -> \""
.
$send_commands
->{
$c
}->{
'desc'
}.
"\""
.
(
$txt
ne
''
?
": $txt"
:
""
), 1);
}
if
(
$cmd_map
->{
$c
}) {
my
$f
=
'rcvd '
.
$cmd_map
->{
$c
};
if
(
$cmd_map
->{
$c
} eq
'R'
) {
my
(
$addr
,
$msb
,
$lsb
) =
unpack
(
"x$len CCC"
,
$chk
);
$f
=
'rcvd eeprom '
.
$addr
;
}
lock
(
$data
->{
$f
});
$data
->{
$f
} = 0;
$self
->_dbg(
"verify_send_command: flag send data->{$f} set to 0"
, 2);
}
$start
+=
$send_commands
->{
$c
}->{
'length'
};
}
else
{
$self
->_dbg(
"verify_send_command: cmd unknown: \""
.
substr
(
$cmd
,
$start
, 2).
"\""
, 1);
$ok
= 0;
last
;
}
}
return
$ok
;
}
sub
verify_recv_command {
my
$self
=
shift
;
my
$cmd
=
shift
;
my
$data
=
$self
->{
'data'
};
my
$c
= _find_cmd(
substr
(
$cmd
, 0, 6),
$recv_commands
);
if
(
$c
) {
my
$len
=
length
(
$c
);
my
$chk
=
substr
(
$cmd
, 0,
$recv_commands
->{
$c
}->{
'length'
});
if
(1 ||
$self
->{
'debug'
}>1) {
my
$type
=
$recv_commands
->{
$c
}->{
'type'
};
my
$txt
= _decode_cmd(
$chk
,
$len
,
$type
);
$type
= 0
if
(!
$type
);
$self
->_dbg(
"verify_recv_command: cmd \"$c\" -> \""
.
$recv_commands
->{
$c
}->{
'desc'
}.
"\""
.
(
$txt
ne
''
?
": $txt"
:
""
), 1);
}
if
(
$c
ne
'R'
) {
my
$f
=
'rcvd '
.
$c
;
lock
(
$data
->{
$f
});
$data
->{
$f
} = 1;
$self
->_dbg(
"verify_recv_command: flag rcvd data->{$f} = 1"
, 2);
$data
->{
'rcvdcmd '
.
$c
} =
$chk
;
cond_signal(
$data
->{
$f
});
}
if
(
defined
(
$set_map
->{
$c
})) {
my
$k
=
$set_map
->{
$c
};
if
(
$data
->{
'changed '
.
$k
}) {
$self
->indirect_write_send;
}
else
{
$data
->{
'ts '
.
$k
} = Time::HiRes::
time
();
}
$data
->{
$k
} =
unpack
(
"x$len C"
,
$cmd
);
$self
->_dbg(
"verify_recv_command: set_map \"$c\" ($k) = "
.
sprintf
(
"%02.2x"
,
$data
->{
$k
}), 2);
}
elsif
(
$c
eq
'R'
) {
my
(
$addr
,
$msb
,
$lsb
) =
unpack
(
"x$len CCC"
,
$chk
);
$data
->{
'eeprom '
.
$addr
} = (
$msb
* 256) +
$lsb
;
$self
->_dbg(
"verify_recv_command: eeprom \"$c\" addr $addr = "
.
sprintf
(
"%02.2x %02.2x"
,
$msb
,
$lsb
), 2);
my
$f
=
'rcvd eeprom '
.
$addr
;
lock
(
$data
->{
$f
});
$data
->{
$f
} = 1;
$self
->_dbg(
"verify_recv_command: flag rcvd data->{$f} set to 1"
, 2);
$data
->{
'rcvdcmd '
.
$c
} =
$chk
;
cond_signal(
$data
->{
$f
});
}
return
$recv_commands
->{
$c
}->{
'length'
};
}
$self
->_dbg(
"verify_recv_command: cmd unknown: \""
.
substr
(
$cmd
, 0, 2).
"\""
, 0);
return
0;
}
sub
send_command {
my
$self
=
shift
;
my
$cmd
=
shift
;
return
0
if
(!verify_send_command(
$self
,
$cmd
));
return
send_pkt(
$self
,
$cmd
);
}
sub
recv_command {
my
$self
=
shift
;
my
$data
=
$self
->{
'data'
};
my
$cmds
=
$self
->recv_pkt;
if
(!
$cmds
) {
return
0;
}
my
@cmds
= ();
while
(
length
(
$cmds
)) {
my
$len
= verify_recv_command(
$self
,
$cmds
);
if
(!
$len
) {
$self
->_dbg(
"recv_command encountered invalid command. Returning "
.
scalar
(
@cmds
).
" commands to caller."
, 0);
last
;
}
push
(
@cmds
,
substr
(
$cmds
, 0,
$len
));
$cmds
=
substr
(
$cmds
,
$len
);
}
$_error
= 0;
return
@cmds
;
}
sub
recv_result {
my
$self
=
shift
;
my
$cmd
=
shift
;
my
$data
=
$self
->{
'data'
};
if
(
$self
->{
'threaded'
}) {
my
$c
= _find_cmd(
$cmd
,
$send_commands
);
$c
= _find_cmd(
$cmd
,
$recv_commands
)
if
(!
$c
);
$c
=
$cmd
if
(!
$c
);
if
(
$cmd_map
->{
$c
}) {
$c
=
$cmd_map
->{
$c
};
}
my
$f
=
'rcvd '
.
$c
;
if
(
$c
eq
'R'
) {
my
$len
=
length
(_find_cmd(
$cmd
,
$send_commands
));
my
(
$addr
,
$msb
,
$lsb
) =
unpack
(
"x$len CCC"
,
$cmd
);
$f
=
'rcvd eeprom '
.
$addr
;
}
my
$timeout
=
time
() +
$self
->{
'recv_timeout'
};
lock
(
$data
->{
$f
});
while
(!
$data
->{
$f
}) {
$self
->_dbg(
"recv_result: flag check data->{$f} = "
.
$data
->{
$f
}, 2);
last
if
(!cond_timedwait(
$data
->{
$f
},
$timeout
));
}
$self
->_dbg(
"recv_result: flag result data->{$f} = "
.
$data
->{
$f
}, 2);
if
(!
$data
->{
$f
}) {
$_error
=
'Timeout waiting for reply'
;
return
undef
;
}
if
(!
defined
(
$data
->{
'rcvdcmd '
.
$c
})) {
$_error
=
'Data not delivered to main thread.'
;
return
0;
}
$_error
= 0;
return
$data
->{
'rcvdcmd '
.
$c
};
}
return
recv_command(
$self
);
}
sub
send_pkt {
my
$self
=
shift
;
my
$pkt
=
shift
;
my
$socket
=
$self
->{
'socket'
};
$self
->_dbg(
"send_pkt: Sending "
.
length
(
$pkt
).
" bytes"
, 1);
$self
->_dbg_packet(
$pkt
, 3);
my
$ret
=
$socket
->
send
(
$pkt
);
if
(!
defined
(
$ret
) ||
$ret
<=0) {
$self
->_dbg(
"send_pkt: Unable to send packet: $!"
, 0);
return
0;
}
return
1;
}
sub
recv_pkt {
my
$self
=
shift
;
my
$data
=
$self
->{
'data'
};
my
$socket
=
$self
->{
'socket'
};
my
@ready
= ();
my
$timeout
=
$self
->{
'service_recv_timeout'
};
my
$sel
= new IO::Select(
$socket
);
@ready
=
$sel
->can_read(
$timeout
);
foreach
my
$fh
(
@ready
) {
if
(
$fh
=
$socket
) {
my
$pkt
;
if
(!
defined
(
$socket
->
recv
(
$pkt
, 8192))) {
$_error
=
"Unable to receive packet: $!"
;
$self
->_dbg(
"recv_pkt: Unable to receive packet: $!"
, 0);
return
0;
}
$self
->_dbg(
"recv_pkt: Received "
.
length
(
$pkt
).
" bytes"
, 1);
$self
->_dbg_packet(
$pkt
, 3);
$_error
= 0;
return
$pkt
;
}
else
{
}
}
return
0;
}
sub
_getgrp {
my
$line
=
shift
;
my
$grp
;
$grp
=
"A"
if
(
$line
>= 0 &&
$line
< 8);
$grp
=
"B"
if
(
$line
>= 8 &&
$line
< 16);
$grp
=
"C"
if
(
$line
>= 16 &&
$line
< 24);
my
$bit
=
$line
% 8;
return
(
$grp
,
$bit
, (1 <<
$bit
));
}
sub
reboot {
my
$self
=
shift
;
return
send_command(
$self
,
"'@"
.
pack
('C*', 0, 0xaa, 0x55));
}
sub
_chkts {
my
$self
=
shift
;
my
$item
=
shift
;
my
$data
=
$self
->{
'data'
};
my
$ts
=
$data
->{
'ts '
.
$item
} +
$self
->{
'indirect_read_interval'
};
my
$now
= Time::HiRes::
time
();
if
(
$self
->{
'direct_reads'
} || (
$ts
<
$now
)) {
if
(
$self
->{
'debug'
}>3) {
if
(
$self
->{
'direct_reads'
}) {
$self
->_dbg(
"_chts: direct_reads, fetching data..."
, 3);
}
else
{
$self
->_dbg(
"_chkts: ts for '$item' (ts=$ts now=$now iv="
.
$self
->{
'indirect_read_interval'
}.
") expired, fetching..."
, 3);
}
}
my
$cmd
=
$status_commands
->{
$item
};
send_command(
$self
,
$cmd
);
recv_result(
$self
,
$cmd
);
return
1;
}
return
0;
}
sub
set_line {
my
$self
=
shift
;
my
$line
=
shift
;
my
$val
=
shift
;
return
undef
if
(!
defined
(
$line
));
return
undef
if
(!
defined
(
$val
));
return
undef
if
(
$line
< 0 ||
$line
> 23);
my
$data
=
$self
->{
'data'
};
my
(
$linegrp
,
$bitno
,
$bitval
) = _getgrp(
$line
);
my
$var
;
$var
=
"dir "
.
$linegrp
;
if
((
$data
->{
$var
} &
$bitval
)) {
$self
->_dbg(
"set_line: line $line ignored, is input"
, 1);
return
0;
}
$var
=
"status "
.
$linegrp
;
if
(
$val
) {
$self
->_dbg(
"set_line: line $line set to ON"
, 1);
$data
->{
$var
} |=
$bitval
;
}
else
{
$self
->_dbg(
"set_line: line $line set to OFF"
, 1);
$data
->{
$var
} &= ~
$bitval
;
}
if
(
$self
->{
'direct_writes'
}) {
return
send_command(
$self
,
$set_commands
->{
$var
}.
pack
(
"C"
,
$data
->{
$var
}));
}
else
{
$data
->{
'changed '
.
$var
} = 1;
return
1;
}
}
sub
get_line_live {
my
$self
=
shift
;
my
$line
=
shift
;
return
undef
if
(!
defined
(
$line
));
return
undef
if
(
$line
< 0 ||
$line
> 23);
my
$data
=
$self
->{
'data'
};
my
(
$linegrp
,
$bitno
,
$bitval
) = _getgrp(
$line
);
my
$var
;
$var
=
"status "
.
$linegrp
;
send_command(
$self
,
$status_commands
->{
$var
});
recv_result(
$self
,
$status_commands
->{
$var
});
$var
=
"status "
.
$linegrp
;
my
$val
= ((
$data
->{
$var
} &
$bitval
) != 0) + 0;
$self
->_dbg(
"get_line_live: line $line = "
.(
$val
?
"ON"
:
"OFF"
), 1);
return
$val
;
}
sub
get_line {
my
$self
=
shift
;
my
$line
=
shift
;
return
undef
if
(!
defined
(
$line
));
return
undef
if
(
$line
< 0 ||
$line
> 23);
my
$data
=
$self
->{
'data'
};
my
(
$linegrp
,
$bitno
,
$bitval
) = _getgrp(
$line
);
my
$var
=
"status "
.
$linegrp
;
$self
->_chkts(
$var
);
my
$val
= ((
$data
->{
$var
} &
$bitval
) != 0) + 0;
$self
->_dbg(
"get_line: line $line = "
.(
$val
?
"ON"
:
"OFF"
), 1);
return
$val
;
}
sub
set_line_dir {
my
$self
=
shift
;
my
$line
=
shift
;
my
$dir
=
shift
;
return
undef
if
(!
defined
(
$line
));
return
undef
if
(
$line
< 0 ||
$line
> 23);
my
$data
=
$self
->{
'data'
};
my
(
$linegrp
,
$bitno
,
$bitval
) = _getgrp(
$line
);
my
$var
;
$var
=
"dir "
.
$linegrp
;
if
(
$dir
) {
$self
->_dbg(
"set_line_dir: line $line set to ON"
, 1);
$data
->{
$var
} |=
$bitval
;
}
else
{
$self
->_dbg(
"set_line_dir: line $line set to OFF"
, 1);
$data
->{
$var
} &= ~
$bitval
;
}
if
(
$self
->{
'direct_writes'
}) {
return
send_command(
$self
,
$set_commands
->{
$var
}.
pack
(
"C"
,
$data
->{
$var
}));
}
else
{
$data
->{
'changed '
.
$var
} = 1;
return
1;
}
}
sub
get_line_dir {
my
$self
=
shift
;
my
$line
=
shift
;
return
undef
if
(!
defined
(
$line
));
return
undef
if
(
$line
< 0 ||
$line
> 23);
my
$data
=
$self
->{
'data'
};
my
(
$linegrp
,
$bitno
,
$bitval
) = _getgrp(
$line
);
my
$var
;
$var
=
"dir "
.
$linegrp
;
$self
->_chkts(
$var
);
my
$val
= ((
$data
->{
$var
} &
$bitval
) != 0) + 0;
$self
->_dbg(
"get_line_dir: line $line = "
.(
$val
?
"IN"
:
"OUT"
), 1);
return
$val
;
}
sub
set_line_pullup {
my
$self
=
shift
;
my
$line
=
shift
;
my
$pullup
=
shift
;
return
undef
if
(!
defined
(
$line
));
return
undef
if
(
$line
< 0 ||
$line
> 23);
my
$data
=
$self
->{
'data'
};
my
(
$linegrp
,
$bitno
,
$bitval
) = _getgrp(
$line
);
my
$var
;
$var
=
"pullup "
.
$linegrp
;
if
(
$pullup
) {
$self
->_dbg(
"set_line_pullup: line $line set to pullup ON"
, 1);
$data
->{
$var
} |=
$bitval
;
}
else
{
$self
->_dbg(
"set_line_pullup: line $line set to pullup OFF"
, 1);
$data
->{
$var
} &= ~
$bitval
;
}
if
(
$self
->{
'direct_writes'
}) {
return
send_command(
$self
,
$set_commands
->{
$var
}.
pack
(
"C"
,
$data
->{
$var
}));
}
else
{
$data
->{
'changed '
.
$var
} = 1;
return
1;
}
}
sub
get_line_pullup {
my
$self
=
shift
;
my
$line
=
shift
;
return
undef
if
(!
defined
(
$line
));
return
undef
if
(
$line
< 0 ||
$line
> 23);
my
$data
=
$self
->{
'data'
};
my
(
$linegrp
,
$bitno
,
$bitval
) = _getgrp(
$line
);
my
$var
;
$var
=
"pullup "
.
$linegrp
;
$self
->_chkts(
$var
);
my
$val
= ((
$data
->{
$var
} &
$bitval
) != 0) + 0;
$self
->_dbg(
"get_line_pullup: line $line = "
.(
$val
?
"pullup ON"
:
"pullup OFF"
), 1);
return
$val
;
}
sub
set_line_thresh {
my
$self
=
shift
;
my
$line
=
shift
;
my
$thresh
=
shift
;
return
undef
if
(!
defined
(
$line
));
return
undef
if
(
$line
< 0 ||
$line
> 23);
my
$data
=
$self
->{
'data'
};
my
(
$linegrp
,
$bitno
,
$bitval
) = _getgrp(
$line
);
my
$var
;
$var
=
"thresh "
.
$linegrp
;
if
(
$thresh
) {
$self
->_dbg(
"set_line_thresh: line $line set to 1.4v (CMOS)"
, 1);
$data
->{
$var
} |=
$bitval
;
}
else
{
$self
->_dbg(
"set_line_thresh: line $line set to 2.5v (TTL)"
, 1);
$data
->{
$var
} &= ~
$bitval
;
}
if
(
$self
->{
'direct_writes'
}) {
return
send_command(
$self
,
$set_commands
->{
$var
}.
pack
(
"C"
,
$data
->{
$var
}));
}
else
{
$data
->{
'changed '
.
$var
} = 1;
return
1;
}
}
sub
get_line_thresh {
my
$self
=
shift
;
my
$line
=
shift
;
return
undef
if
(!
defined
(
$line
));
return
undef
if
(
$line
< 0 ||
$line
> 23);
my
$data
=
$self
->{
'data'
};
my
(
$linegrp
,
$bitno
,
$bitval
) = _getgrp(
$line
);
my
$var
;
$var
=
"thresh "
.
$linegrp
;
$self
->_chkts(
$var
);
my
$val
= ((
$data
->{
$var
} &
$bitval
) != 0) + 0;
$self
->_dbg(
"get_line_thresh: line $line = "
.(
$val
?
"1.4v (CMOS)"
:
"2.5v (TTL)"
), 1);
return
$val
;
}
sub
set_line_schmitt {
my
$self
=
shift
;
my
$line
=
shift
;
my
$schmitt
=
shift
;
return
undef
if
(!
defined
(
$line
));
return
undef
if
(
$line
< 0 ||
$line
> 23);
my
$data
=
$self
->{
'data'
};
my
(
$linegrp
,
$bitno
,
$bitval
) = _getgrp(
$line
);
my
$var
;
$var
=
"schmitt "
.
$linegrp
;
if
(
$schmitt
) {
$self
->_dbg(
"set_line_schmitt: line $line set to ON"
, 1);
$data
->{
$var
} |=
$bitval
;
}
else
{
$self
->_dbg(
"set_line_schmitt: line $line set to OFF"
, 1);
$data
->{
$var
} &= ~
$bitval
;
}
if
(
$self
->{
'direct_writes'
}) {
return
send_command(
$self
,
$set_commands
->{
$var
}.
pack
(
"C"
,
$data
->{
$var
}));
}
else
{
$data
->{
'changed '
.
$var
} = 1;
return
1;
}
}
sub
get_line_schmitt {
my
$self
=
shift
;
my
$line
=
shift
;
return
undef
if
(!
defined
(
$line
));
return
undef
if
(
$line
< 0 ||
$line
> 23);
my
$data
=
$self
->{
'data'
};
my
(
$linegrp
,
$bitno
,
$bitval
) = _getgrp(
$line
);
my
$var
;
$var
=
"schmitt "
.
$linegrp
;
$self
->_chkts(
$var
);
my
$val
= ((
$data
->{
$var
} &
$bitval
) != 0) + 0;
$self
->_dbg(
"get_line_schmitt: line $line = "
.(
$val
?
"IN"
:
"OUT"
), 1);
return
$val
;
}
sub
set_autoscan_addr {
my
$self
=
shift
;
my
$addr
=
shift
;
my
$port
=
shift
;
my
$data
=
$self
->{
'data'
};
if
(!
$self
->{
'prefetch_status'
}) {
eeprom_fetch(
$self
, 1);
}
$data
->{
'eeprom 5'
} &= ~5;
send_command(
$self
,
"'W"
.
pack
('C*
', 5, ($data->{'
eeprom 5
'} >> 8) & 0xff, $data->{'
eeprom 5'} & 0xff));
}
sub
set_autoscan_line {
my
$self
=
shift
;
my
$line
=
shift
;
my
$state
=
shift
|| 1;
}
sub
set_startup_status {
my
$self
=
shift
;
my
$state
=
shift
|| 1;
my
$data
=
$self
->{
'data'
};
if
(!
$self
->{
'prefetch_status'
}) {
$self
->status_fetch(1);
$self
->eeprom_fetch(1);
}
my
$fields
= {
8
=> [
'status A'
,
'dir A'
],
9
=> [
'pullup A'
,
'thresh A'
],
10
=> [
'dir B'
,
'schmitt A'
],
11
=> [
'thresh B'
,
'status B'
],
12
=> [
'schmitt B'
,
'pullup B'
],
13
=> [
'status C'
,
'dir C'
],
14
=> [
'pullup C'
,
'thresh C'
],
15
=> [ 0,
'schmitt C'
],
};
send_command(
$self
,
"'1"
.
pack
('CCC', 0, 0xaa, 0x55));
if
(
$state
) {
$data
->{
'eeprom 5'
} &= ~2;
send_command(
$self
,
"'W"
.
pack
('CCC
', 5, ($data->{'
eeprom 5
'} >> 8) & 0xff, $data->{'
eeprom 5'} & 0xff));
foreach
my
$field
(
sort
{
$a
<=>
$b
}
keys
%$fields
) {
my
$arr
=
$fields
->{
$field
};
$data
->{
'eeprom '
.
$field
} = ((
@$arr
[0]?
$data
->{
@$arr
[0]}:0) * 256) + (
@$arr
[1]?
$data
->{
@$arr
[1]}:0);
send_command(
$self
,
"'W"
.
pack
('CCC
', $field, ($data->{'
eeprom
'.$field} >> 8) & 0xff, $data->{'
eeprom '.
$field
} & 0xff));
}
}
else
{
$data
->{
'eeprom 5'
} |= 2;
send_command(
$self
,
"'W"
.
pack
('C*
', 5, ($data->{'
eeprom 5
'} >> 8) & 0xff, $data->{'
eeprom 5'} & 0xff));
foreach
my
$field
(
sort
{
$a
<=>
$b
}
keys
%$fields
) {
send_command(
$self
,
"'W"
.
pack
('CCC',
$field
, 0xff, 0xff));
}
}
send_command(
$self
,
"'0"
.
pack
('CCC', 0, 0xaa, 0x55));
}
1;