zoneminder/onvif/modules/lib/WSDiscovery/TransportUDP.pm

164 lines
4.5 KiB
Perl
Raw Normal View History

2014-07-15 02:36:18 +08:00
# ==========================================================================
#
# Perl WS-Discovery implementation
2016-02-10 23:36:21 +08:00
# Copyright (C) 2014 Jan M. Hochstein
2014-07-15 02:36:18 +08:00
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
2016-12-27 00:33:03 +08:00
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
2014-07-15 02:36:18 +08:00
#
# ==========================================================================
#
# UDP Transport for SOAP WS-Discovery to be used with SOAP::WSDL::Client
#
package WSDiscovery::TransportUDP;
use strict;
use warnings;
use Class::Std::Fast::Storable;
use IO::Socket::Multicast;
use SOAP::WSDL::Factory::Transport;
use Time::HiRes qw( usleep );
use version; our $VERSION = qv('1.00.00');
2014-08-18 03:24:27 +08:00
# 20 times 200 msec = 4sec timeout
use constant WAIT_TIME => 200.0;
use constant WAIT_COUNT => 20;
2014-07-15 02:36:18 +08:00
SOAP::WSDL::Factory::Transport->register( 'soap.udp' => __PACKAGE__ );
my %code_of :ATTR(:name<code> :default<()>);
my %status_of :ATTR(:name<status> :default<()>);
my %message_of :ATTR(:name<message> :default<()>);
my %is_success_of :ATTR(:name<is_success> :default<()>);
my %local_addr_of :ATTR(:name<local_addr> :init_arg<local_addr> :default<()>);
# create methods normally inherited from SOAP::Client
SUBFACTORY: {
no strict qw(refs);
foreach my $method ( qw(code message status is_success) ) {
*{ $method } = *{ "get_$method" };
}
}
2014-08-18 03:24:27 +08:00
# override to receive more than one response
sub _notify_response
{
# my ($transport, $response) = @_;
}
2014-07-15 02:36:18 +08:00
sub send_multi() {
my ($self, $address, $port, $utf8_string) = @_;
2014-07-15 02:36:18 +08:00
my $destination = $address . ':' . $port;
my $socket = IO::Socket::Multicast->new(PROTO => 'udp',
LocalPort=>$port, PeerAddr=>$destination, ReuseAddr=>1)
or die 'Cannot open multicast socket to ' . ${address} . ':' . ${port};
my $bytes = $utf8_string;
utf8::encode($bytes);
2014-07-15 02:36:18 +08:00
$socket->mcast_ttl(1);
$socket->send($bytes);
2014-07-15 02:36:18 +08:00
}
sub receive_multi() {
my ($self, $address, $port) = @_;
my $data = undef;
my $socket = IO::Socket::Multicast->new(PROTO => 'udp',
LocalPort=>$port, ReuseAddr=>1);
$socket->mcast_add($address);
2014-08-18 03:24:27 +08:00
my $readbits = '';
vec($readbits, $socket->fileno, 1) = 1;
2014-07-15 02:36:18 +08:00
2014-08-18 03:24:27 +08:00
if(select($readbits, undef, undef, WAIT_TIME/1000)) {
$socket->recv($data, 9999);
return $data;
}
return undef;
2014-07-15 02:36:18 +08:00
}
sub receive_uni() {
my ($self, $address, $port, $localaddr) = @_;
my $data = undef;
my $socket = IO::Socket::Multicast->new(PROTO => 'udp',
LocalAddr => $localaddr, LocalPort=>$port, ReuseAddr=>1);
$socket->mcast_add($address);
2014-08-18 03:24:27 +08:00
my $readbits = '';
vec($readbits, $socket->fileno, 1) = 1;
2014-07-15 02:36:18 +08:00
2014-08-18 03:24:27 +08:00
if(select($readbits, undef, undef, WAIT_TIME/1000)) {
$socket->recv($data, 9999);
return $data;
}
return undef;
2014-07-15 02:36:18 +08:00
}
sub send_receive {
my ($self, %parameters) = @_;
my ($envelope, $soap_action, $endpoint, $encoding, $content_type) =
@parameters{qw(envelope action endpoint encoding content_type)};
my ($address,$port) = ($endpoint =~ /([^:\/]+):([0-9]+)/);
# warn "address = ${address}";
# warn "port = ${port}";
$self->send_multi($address, $port, $envelope);
my $localaddr = $self->get_local_addr();
2014-08-18 03:24:27 +08:00
my ($response, $last_response);
2014-07-15 02:36:18 +08:00
my $wait = WAIT_COUNT;
2014-08-18 03:24:27 +08:00
while ( $wait >= 0 ) {
2014-07-15 02:36:18 +08:00
if($localaddr) {
if($response = $self->receive_uni($address, $port, $localaddr)) {
2014-08-18 03:24:27 +08:00
$last_response = $response;
$self->_notify_response($response);
2014-07-15 02:36:18 +08:00
}
2014-08-18 03:24:27 +08:00
$wait --;
2014-07-15 02:36:18 +08:00
}
if($response = $self->receive_multi($address, $port)) {
2014-08-18 03:24:27 +08:00
$last_response = $response;
$self->_notify_response($response);
2014-07-15 02:36:18 +08:00
}
$wait --;
}
2014-08-18 03:24:27 +08:00
if($last_response) {
2016-06-18 21:46:05 +08:00
$self->set_code();
$self->set_message("");
$self->set_is_success(1);
$self->set_status('OK');
2014-07-15 02:36:18 +08:00
}
else{
2016-06-18 21:46:05 +08:00
$self->set_code();
$self->set_message("Timed out waiting for response");
$self->set_is_success(0);
$self->set_status('TIMEOUT');
2014-07-15 02:36:18 +08:00
}
2016-06-18 21:46:05 +08:00
2014-08-18 03:24:27 +08:00
return $last_response;
2014-07-15 02:36:18 +08:00
}
1;