Merge pull request #2840 from connortechnology/onvif_multicast_route

Onvif multicast route
This commit is contained in:
Isaac Connor 2020-02-19 14:48:50 -05:00 committed by GitHub
commit 0d91f5965d
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
4 changed files with 98 additions and 68 deletions

View File

@ -43,7 +43,7 @@ my %message_of :ATTR(:name<message> :default<()>);
my %is_success_of :ATTR(:name<is_success> :default<()>); my %is_success_of :ATTR(:name<is_success> :default<()>);
my %local_addr_of :ATTR(:name<local_addr> :init_arg<local_addr> :default<()>); my %local_addr_of :ATTR(:name<local_addr> :init_arg<local_addr> :default<()>);
my $net_interface;
# create methods normally inherited from SOAP::Client # create methods normally inherited from SOAP::Client
SUBFACTORY: { SUBFACTORY: {
@ -60,14 +60,22 @@ sub _notify_response
} }
sub set_net_interface {
my $self = shift;
$net_interface = shift;
}
sub send_multi() { sub send_multi() {
my ($self, $address, $port, $utf8_string) = @_; my ($self, $address, $port, $utf8_string) = @_;
my $destination = $address . ':' . $port; my $destination = $address . ':' . $port;
my $socket = IO::Socket::Multicast->new(PROTO => 'udp', my $socket = IO::Socket::Multicast->new(
LocalPort=>$port, PeerAddr=>$destination, ReuseAddr=>1) PROTO => 'udp',
LocalPort=>$port,
or die 'Cannot open multicast socket to ' . ${address} . ':' . ${port}; PeerAddr=>$destination,
ReuseAddr=>1
) or die 'Cannot open multicast socket to ' . ${address} . ':' . ${port};
$_ = $socket->mcast_if($net_interface) if $net_interface;
my $bytes = $utf8_string; my $bytes = $utf8_string;
utf8::encode($bytes); utf8::encode($bytes);
@ -80,14 +88,16 @@ sub receive_multi() {
my ($self, $address, $port) = @_; my ($self, $address, $port) = @_;
my $data = undef; my $data = undef;
my $socket = IO::Socket::Multicast->new(PROTO => 'udp', my $socket = IO::Socket::Multicast->new(
LocalPort=>$port, ReuseAddr=>1); PROTO => 'udp',
$socket->mcast_add($address); LocalPort=>$port,
ReuseAddr=>1);
$socket->mcast_add($address, $net_interface);
my $readbits = ''; my $readbits = '';
vec($readbits, $socket->fileno, 1) = 1; vec($readbits, $socket->fileno, 1) = 1;
if(select($readbits, undef, undef, WAIT_TIME/1000)) { if ( select($readbits, undef, undef, WAIT_TIME/1000) ) {
$socket->recv($data, 9999); $socket->recv($data, 9999);
return $data; return $data;
} }
@ -98,15 +108,19 @@ sub receive_uni() {
my ($self, $address, $port, $localaddr) = @_; my ($self, $address, $port, $localaddr) = @_;
my $data = undef; my $data = undef;
my $socket = IO::Socket::Multicast->new(PROTO => 'udp', my $socket = IO::Socket::Multicast->new(
LocalAddr => $localaddr, LocalPort=>$port, ReuseAddr=>1); PROTO => 'udp',
LocalAddr => $localaddr,
LocalPort=>$port,
ReuseAddr=>1
);
$socket->mcast_add($address); $socket->mcast_add($address, $net_interface);
my $readbits = ''; my $readbits = '';
vec($readbits, $socket->fileno, 1) = 1; vec($readbits, $socket->fileno, 1) = 1;
if(select($readbits, undef, undef, WAIT_TIME/1000)) { if ( select($readbits, undef, undef, WAIT_TIME/1000) ) {
$socket->recv($data, 9999); $socket->recv($data, 9999);
return $data; return $data;
} }
@ -114,50 +128,51 @@ sub receive_uni() {
} }
sub send_receive { sub send_receive {
my ($self, %parameters) = @_; my ($self, %parameters) = @_;
my ($envelope, $soap_action, $endpoint, $encoding, $content_type) = my ($envelope, $soap_action, $endpoint, $encoding, $content_type) =
@parameters{qw(envelope action endpoint encoding content_type)}; @parameters{qw(envelope action endpoint encoding content_type)};
my ($address,$port) = ($endpoint =~ /([^:\/]+):([0-9]+)/); my ($address,$port) = ($endpoint =~ /([^:\/]+):([0-9]+)/);
#warn "address = ${address}"; #warn "address = ${address}";
#warn "port = ${port}"; #warn "port = ${port}";
$self->send_multi($address, $port, $envelope); $self->send_multi($address, $port, $envelope);
my $localaddr = $self->get_local_addr(); my $localaddr = $self->get_local_addr();
#warn "localddr $localaddr";
my ($response, $last_response); my ($response, $last_response);
my $wait = WAIT_COUNT; my $wait = WAIT_COUNT;
while ( $wait >= 0 ) { while ( $wait >= 0 ) {
if($localaddr) { if ( $localaddr ) {
if($response = $self->receive_uni($address, $port, $localaddr)) { if ( $response = $self->receive_uni($address, $port, $localaddr) ) {
$last_response = $response; $last_response = $response;
$self->_notify_response($response); $self->_notify_response($response);
} }
$wait --; $wait --;
} }
if($response = $self->receive_multi($address, $port)) { if ( $response = $self->receive_multi($address, $port) ) {
$last_response = $response; $last_response = $response;
$self->_notify_response($response); $self->_notify_response($response);
} }
$wait --; $wait --;
} }
if($last_response) {
$self->set_code();
$self->set_message("");
$self->set_is_success(1);
$self->set_status('OK');
}
else{
$self->set_code();
$self->set_message("Timed out waiting for response");
$self->set_is_success(0);
$self->set_status('TIMEOUT');
}
return $last_response; if ( $last_response ) {
$self->set_code();
$self->set_message('');
$self->set_is_success(1);
$self->set_status('OK');
} else {
$self->set_code();
$self->set_message('Timed out waiting for response');
$self->set_is_success(0);
$self->set_status('TIMEOUT');
}
return $last_response;
} }
1; 1;
__END__

View File

@ -172,7 +172,7 @@ sub interpret_messages {
# functions # functions
sub discover { sub discover {
my ( $soap_version ) = @_; my ( $soap_version, $net_interface ) = @_;
my @results; my @results;
## collect all responses ## collect all responses
@ -190,22 +190,27 @@ sub discover {
my $uuid_gen = Data::UUID->new(); my $uuid_gen = Data::UUID->new();
if ( ( ! $soap_version ) or ( $soap_version eq '1.1' ) ) { if ( ( ! $soap_version ) or ( $soap_version eq '1.1' ) ) {
my %services; my %services;
if($verbose) { if ( $verbose ) {
print "Probing for SOAP 1.1\n" print "Probing for SOAP 1.1\n";
} }
my $svc_discover = WSDiscovery10::Interfaces::WSDiscovery::WSDiscoveryPort->new({ my $svc_discover = WSDiscovery10::Interfaces::WSDiscovery::WSDiscoveryPort->new({
# no_dispatch => '1', # no_dispatch => '1',
}); });
$svc_discover->set_soap_version('1.1'); $svc_discover->set_soap_version('1.1');
if ( $net_interface ) {
my $transport = $svc_discover->get_transport();
print "Setting net interface for $transport to $net_interface\n";
$transport->set_net_interface($net_interface);
}
my $uuid = $uuid_gen->create_str(); my $uuid = $uuid_gen->create_str();
my $result = $svc_discover->ProbeOp( my $result = $svc_discover->ProbeOp(
{ # WSDiscovery::Types::ProbeType { # WSDiscovery::Types::ProbeType
Types => 'http://www.onvif.org/ver10/network/wsdl:NetworkVideoTransmitter http://www.onvif.org/ver10/device/wsdl:Device', # QNameListType Types => 'http://www.onvif.org/ver10/network/wsdl:NetworkVideoTransmitter http://www.onvif.org/ver10/device/wsdl:Device', # QNameListType
Scopes => { value => '' }, Scopes => { value => '' },
}, },
WSDiscovery10::Elements::Header->new({ WSDiscovery10::Elements::Header->new({
Action => { value => 'http://schemas.xmlsoap.org/ws/2005/04/discovery/Probe' }, Action => { value => 'http://schemas.xmlsoap.org/ws/2005/04/discovery/Probe' },
@ -220,14 +225,19 @@ sub discover {
} # end if doing soap 1.1 } # end if doing soap 1.1
if ( ( ! $soap_version ) or ( $soap_version eq '1.2' ) ) { if ( ( ! $soap_version ) or ( $soap_version eq '1.2' ) ) {
my %services; my %services;
if($verbose) { if ( $verbose ) {
print "Probing for SOAP 1.2\n" print "Probing for SOAP 1.2\n";
} }
my $svc_discover = WSDiscovery10::Interfaces::WSDiscovery::WSDiscoveryPort->new({ my $svc_discover = WSDiscovery10::Interfaces::WSDiscovery::WSDiscoveryPort->new({
# no_dispatch => '1', # no_dispatch => '1',
}); });
$svc_discover->set_soap_version('1.2'); $svc_discover->set_soap_version('1.2');
if ( $net_interface ) {
my $transport = $svc_discover->get_transport();
print "Setting net interface for $transport to $net_interface\n";
$transport->set_net_interface($net_interface);
}
# copies of the same Probe message must have the same MessageID. # copies of the same Probe message must have the same MessageID.
# This is not a copy. So we generate a new uuid. # This is not a copy. So we generate a new uuid.
@ -250,7 +260,7 @@ sub discover {
push @results, interpret_messages($svc_discover, \%services, @responses); push @results, interpret_messages($svc_discover, \%services, @responses);
} # end if doing soap 1.2 } # end if doing soap 1.2
return @results; return @results;
} } # end sub discover
sub profiles { sub profiles {
my ( $client ) = @_; my ( $client ) = @_;

View File

@ -352,9 +352,13 @@ sub exportsql {
} }
my $name = $ARGV[0]; my $name = $ARGV[0];
if ($name && $name =~ /^([A-Za-z0-9 ,.&()\/\-]+)$/) { # Allow alphanumeric and " ,.&()/-" if ( $name ) {
$name = $1; if ( $name =~ /^([A-Za-z0-9 ,.&()\/\-]+)$/ ) { # Allow alphanumeric and " ,.&()/-"
$command .= qq( --where="Name = '$name'"); $name = $1;
$command .= qq( --where="Name = '$name'");
} else {
print "Invalid characters in Name\n";
}
} }
$command .= " zm Controls MonitorPresets"; $command .= " zm Controls MonitorPresets";

View File

@ -41,7 +41,7 @@ my $OPTIONS = 'v';
sub HELP_MESSAGE { sub HELP_MESSAGE {
my ($fh, $pkg, $ver, $opts) = @_; my ($fh, $pkg, $ver, $opts) = @_;
print $fh "Usage: " . __FILE__ . " [-v] probe <soap version>\n"; print $fh "Usage: " . __FILE__ . " [-v] probe <soap version> <network interface>\n";
print $fh " " . __FILE__ . " [-v] <command> <device URI> <soap version> <user> <password>\n"; print $fh " " . __FILE__ . " [-v] <command> <device URI> <soap version> <user> <password>\n";
print $fh <<EOF print $fh <<EOF
Commands are: Commands are:
@ -69,7 +69,7 @@ if ( !getopts($OPTIONS) ) {
my $action = shift; my $action = shift;
if(!defined $action) { if ( ! defined $action ) {
HELP_MESSAGE(\*STDOUT); HELP_MESSAGE(\*STDOUT);
exit(1); exit(1);
} }
@ -84,7 +84,8 @@ if ( defined $opt_v ) {
if ( $action eq 'probe' ) { if ( $action eq 'probe' ) {
my $soap_version = shift; my $soap_version = shift;
ZoneMinder::ONVIF::discover($soap_version); my $net_interface = shift;
ZoneMinder::ONVIF::discover($soap_version, $net_interface);
} else { } else {
# all other actions need URI and credentials # all other actions need URI and credentials
my $url_svc_device = shift @ARGV; my $url_svc_device = shift @ARGV;