Merge pull request #2840 from connortechnology/onvif_multicast_route
Onvif multicast route
This commit is contained in:
commit
0d91f5965d
|
@ -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;
|
||||||
}
|
}
|
||||||
|
@ -120,39 +134,39 @@ sub send_receive {
|
||||||
|
|
||||||
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) {
|
if ( $last_response ) {
|
||||||
$self->set_code();
|
$self->set_code();
|
||||||
$self->set_message("");
|
$self->set_message('');
|
||||||
$self->set_is_success(1);
|
$self->set_is_success(1);
|
||||||
$self->set_status('OK');
|
$self->set_status('OK');
|
||||||
}
|
} else {
|
||||||
else{
|
|
||||||
$self->set_code();
|
$self->set_code();
|
||||||
$self->set_message("Timed out waiting for response");
|
$self->set_message('Timed out waiting for response');
|
||||||
$self->set_is_success(0);
|
$self->set_is_success(0);
|
||||||
$self->set_status('TIMEOUT');
|
$self->set_status('TIMEOUT');
|
||||||
}
|
}
|
||||||
|
@ -161,3 +175,4 @@ sub send_receive {
|
||||||
}
|
}
|
||||||
|
|
||||||
1;
|
1;
|
||||||
|
__END__
|
||||||
|
|
|
@ -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
|
||||||
|
@ -192,13 +192,18 @@ sub discover {
|
||||||
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();
|
||||||
|
|
||||||
|
@ -221,13 +226,18 @@ sub discover {
|
||||||
|
|
||||||
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 ) = @_;
|
||||||
|
|
|
@ -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 ) {
|
||||||
|
if ( $name =~ /^([A-Za-z0-9 ,.&()\/\-]+)$/ ) { # Allow alphanumeric and " ,.&()/-"
|
||||||
$name = $1;
|
$name = $1;
|
||||||
$command .= qq( --where="Name = '$name'");
|
$command .= qq( --where="Name = '$name'");
|
||||||
|
} else {
|
||||||
|
print "Invalid characters in Name\n";
|
||||||
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
$command .= " zm Controls MonitorPresets";
|
$command .= " zm Controls MonitorPresets";
|
||||||
|
|
|
@ -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;
|
||||||
|
|
Loading…
Reference in New Issue