Basic support for SOAP 1.1 and 1.2
This commit is contained in:
Jan M. Hochstein
parent
6d4d7dc372
commit
a18399af69
|
|
@ -29,10 +29,18 @@ use Class::Std::Fast;
|
|||
|
||||
use version; our $VERSION = qv('1.00.00');
|
||||
|
||||
## Transport
|
||||
require SOAP::WSDL::Transport::HTTP;
|
||||
|
||||
## Serializer
|
||||
require ONVIF::Serializer::SOAP11;
|
||||
require ONVIF::Serializer::SOAP12;
|
||||
require WSSecurity::SecuritySerializer;
|
||||
|
||||
## Deserializer
|
||||
require ONVIF::Deserializer::XSD;
|
||||
|
||||
## ONVIF APIs
|
||||
require ONVIF::Device::Interfaces::Device::DevicePort;
|
||||
require ONVIF::Media::Interfaces::Media::MediaPort;
|
||||
require ONVIF::PTZ::Interfaces::PTZ::PTZPort;
|
||||
|
|
@ -61,6 +69,7 @@ my %namespace_map = (
|
|||
my %services_of :ATTR(:default<{}>);
|
||||
|
||||
my %serializer_of :ATTR();
|
||||
my %soap_version_of :ATTR(:default<('1.1')>);
|
||||
|
||||
# =========================================================================
|
||||
# private methods
|
||||
|
|
@ -89,6 +98,20 @@ sub set_serializer
|
|||
$serializer_of{ident $self} = $serializer;
|
||||
}
|
||||
|
||||
sub soap_version
|
||||
{
|
||||
my ($self) = @_;
|
||||
$soap_version_of{ident $self};
|
||||
}
|
||||
|
||||
sub set_soap_version
|
||||
{
|
||||
my ($self, $soap_version) = @_;
|
||||
$soap_version_of{ident $self} = $soap_version;
|
||||
|
||||
# setting the soap version invalidates the serializer
|
||||
delete $serializer_of{ ident $self };
|
||||
}
|
||||
|
||||
sub get_service_urls
|
||||
{
|
||||
|
|
@ -139,10 +162,20 @@ sub BUILD
|
|||
my ($self, $ident, $args_ref) = @_;
|
||||
|
||||
my $url_svc_device = $args_ref->{'url_svc_device'};
|
||||
my $soap_version = $args_ref->{'soap_version'};
|
||||
if(! $soap_version) {
|
||||
$soap_version = '1.1';
|
||||
}
|
||||
$self->set_soap_version($soap_version);
|
||||
|
||||
my $serializer = ONVIF::Serializer::Base->new();
|
||||
$serializer->set_soap_version($soap_version);
|
||||
|
||||
my $svc_device = ONVIF::Device::Interfaces::Device::DevicePort->new({
|
||||
proxy => $url_svc_device,
|
||||
deserializer_args => { strict => 0 }
|
||||
serializer => $serializer,
|
||||
# "strict => 0" does not work with SOAP header
|
||||
# deserializer_args => { strict => 0 }
|
||||
});
|
||||
|
||||
$services_of{$ident}{'device'} = { url => $url_svc_device, ep => $svc_device };
|
||||
|
|
@ -196,6 +229,7 @@ sub set_credentials
|
|||
|
||||
## from here on use authorization
|
||||
$self->set_serializer( WSSecurity::SecuritySerializer->new() );
|
||||
$self->serializer()->set_soap_version($self->soap_version());
|
||||
$self->serializer()->set_username($username);
|
||||
$self->serializer()->set_password($password);
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,267 @@
|
|||
#!/usr/bin/perl
|
||||
package ONVIF::Deserializer::MessageParser;
|
||||
use strict; use warnings;
|
||||
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin;
|
||||
use SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType;
|
||||
|
||||
## copied from SOAP::Constants
|
||||
use constant URI_SOAP11_ENV => "http://schemas.xmlsoap.org/soap/envelope/";
|
||||
use constant URI_SOAP12_ENV => "http://www.w3.org/2003/05/soap-envelope";
|
||||
|
||||
## copied and adapted from
|
||||
use base qw(SOAP::WSDL::Expat::MessageParser);
|
||||
|
||||
## we get the soap version from the message
|
||||
my %soap_version_of; # :ATTR( :default<()>);
|
||||
|
||||
sub soap_version {
|
||||
my ($self) = @_;
|
||||
$soap_version_of{ident $self};
|
||||
}
|
||||
|
||||
# override new() to pass along the init_args
|
||||
sub new {
|
||||
my ($class, $args) = @_;
|
||||
my $self = {
|
||||
class_resolver => $args->{ class_resolver },
|
||||
strict => defined $args->{ strict } ? $args->{ strict } : 1,
|
||||
};
|
||||
|
||||
bless $self, $class;
|
||||
|
||||
# could be written as && - but Devel::Cover doesn't like that
|
||||
if ($args->{ class_resolver }) {
|
||||
$self->load_classes()
|
||||
if ! exists $SOAP::WSDL::Expat::MessageParser::LOADED_OF{ $self->{ class_resolver } };
|
||||
}
|
||||
return $self;
|
||||
## calling the parent's calss new() dows not work here.
|
||||
# return SOAP::WSDL::Expat::MessageParser->new($class, $args);
|
||||
}
|
||||
|
||||
sub _initialize {
|
||||
my ($self, $parser) = @_;
|
||||
|
||||
$self->{ parser } = $parser;
|
||||
|
||||
delete $self->{ data }; # remove potential old results
|
||||
delete $self->{ header };
|
||||
|
||||
my $characters;
|
||||
|
||||
# Note: $current MUST be undef - it is used as sentinel
|
||||
# on the object stack via if (! defined $list->[-1])
|
||||
# DON'T set it to anything else !
|
||||
my $current = undef;
|
||||
my $list = []; # node list (object stack)
|
||||
|
||||
my $path = []; # current path
|
||||
my $skip = 0; # skip elements
|
||||
my $depth = 0;
|
||||
|
||||
my %content_check = $self->{strict}
|
||||
? (
|
||||
0 => sub {
|
||||
die "Bad top node $_[1]" if $_[1] ne 'Envelope';
|
||||
if($_[0]->namespace($_[1]) eq URI_SOAP11_ENV) {
|
||||
$_[0]{ soap_version } = '1.1';
|
||||
# $soap_version_of{ident $_[0]} = '1.1';
|
||||
}
|
||||
elsif($_[0]->namespace($_[1]) eq URI_SOAP12_ENV) {
|
||||
$_[0]{ soap_version } = '1.2';
|
||||
}
|
||||
else {
|
||||
die "Bad namespace for SOAP envelope: " . $_[0]->recognized_string();
|
||||
}
|
||||
#print "Receiving SOAP " . $_[0]{ soap_version } ."\n";
|
||||
$depth++;
|
||||
return;
|
||||
},
|
||||
1 => sub {
|
||||
# Header or Body
|
||||
#print "Start $_[1] at level 1\n";
|
||||
$depth++;
|
||||
if ($_[1] eq 'Body') {
|
||||
if (exists $self->{ data }) { # there was header data
|
||||
$self->{ header } = $self->{ data };
|
||||
delete $self->{ data };
|
||||
$list = [];
|
||||
$path = [];
|
||||
undef $current;
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
)
|
||||
: (
|
||||
0 => sub { $depth++ },
|
||||
1 => sub { $depth++ },
|
||||
);
|
||||
|
||||
# use "globals" for speed
|
||||
my ($_prefix, $_method, $_class, $_leaf) = ();
|
||||
|
||||
my $char_handler = sub {
|
||||
return if (!$_leaf); # we only want characters in leaf nodes
|
||||
$characters .= $_[1]; # add to characters
|
||||
return; # return void
|
||||
};
|
||||
|
||||
no strict qw(refs);
|
||||
$parser->setHandlers(
|
||||
Start => sub {
|
||||
# my ($parser, $element, %attrs) = @_;
|
||||
|
||||
#print "Start $_[1]\n";
|
||||
|
||||
$_leaf = 1; # believe we're a leaf node until we see an end
|
||||
|
||||
# call methods without using their parameter stack
|
||||
# That's slightly faster than $content_check{ $depth }->()
|
||||
# and we don't have to pass $_[1] to the method.
|
||||
# Yup, that's dirty.
|
||||
return &{$content_check{ $depth }}
|
||||
if exists $content_check{ $depth };
|
||||
|
||||
push @{ $path }, $_[1]; # step down in path
|
||||
return if $skip; # skip inside __SKIP__
|
||||
|
||||
# resolve class of this element
|
||||
$_class = $self->{ class_resolver }->get_class( $path );
|
||||
|
||||
# we cannot use this if there are <xs:any> elements
|
||||
# if (! defined($_class) and $self->{ strict }) {
|
||||
# die "Cannot resolve class for "
|
||||
# . join('/', @{ $path }) . " via " . $self->{ class_resolver };
|
||||
# }
|
||||
|
||||
if (! defined($_class) or ($_class eq '__SKIP__') ) {
|
||||
$skip = join('/', @{ $path });
|
||||
$_[0]->setHandlers( Char => undef );
|
||||
return;
|
||||
}
|
||||
|
||||
# step down in tree (remember current)
|
||||
#
|
||||
# on the first object (after skipping Envelope/Body), $current
|
||||
# is undef.
|
||||
# We put it on the stack, anyway, and use it as sentinel when
|
||||
# going through the closing tags in the End handler
|
||||
#
|
||||
push @$list, $current;
|
||||
|
||||
# cleanup. Mainly here to help profilers find the real hot spots
|
||||
undef $current;
|
||||
|
||||
# cleanup
|
||||
$characters = q{};
|
||||
|
||||
# Create and set new objects using Class::Std::Fast's object cache
|
||||
# if possible, or blessing directly into the class in question
|
||||
# (circumventing constructor) here.
|
||||
# That's dirty, but fast.
|
||||
#
|
||||
# TODO: check whether this is faster under all perls - there's
|
||||
# strange benchmark results...
|
||||
#
|
||||
# The alternative would read:
|
||||
# $current = $_class->new({ @_[2..$#_] });
|
||||
#
|
||||
$current = pop @{ $SOAP::WSDL::Expat::MessageParser::OBJECT_CACHE_REF->{ $_class } };
|
||||
if (not defined $current) {
|
||||
my $o = Class::Std::Fast::ID();
|
||||
$current = bless \$o, $_class;
|
||||
}
|
||||
|
||||
# set attributes if there are any
|
||||
ATTR: {
|
||||
if (@_ > 2) {
|
||||
# die Data::Dumper::Dumper(@_[2..$#_]);
|
||||
my %attr = @_[2..$#_];
|
||||
if (my $nil = delete $attr{nil}) {
|
||||
# TODO: check namespace
|
||||
if ($nil && $nil ne 'false') {
|
||||
undef $characters;
|
||||
last ATTR if not (%attr);
|
||||
}
|
||||
}
|
||||
$current->attr(\%attr);
|
||||
}
|
||||
}
|
||||
$depth++;
|
||||
|
||||
# TODO: Skip content of anyType / any stuff
|
||||
|
||||
return;
|
||||
},
|
||||
|
||||
Char => $char_handler,
|
||||
|
||||
End => sub {
|
||||
|
||||
#print "End $_[1]\n";
|
||||
pop @{ $path }; # step up in path
|
||||
|
||||
# check __SKIP__
|
||||
if ($skip) {
|
||||
return if $skip ne join '/', @{ $path }, $_[1];
|
||||
$skip = 0;
|
||||
$_[0]->setHandlers( Char => $char_handler );
|
||||
return;
|
||||
}
|
||||
|
||||
$depth--;
|
||||
|
||||
# we only set character values in leaf nodes
|
||||
if ($_leaf) {
|
||||
# Use dirty but fast access via global variables.
|
||||
#
|
||||
# The normal way (via method) would be this:
|
||||
#
|
||||
# $current->set_value( $characters ) if (length($characters));
|
||||
#
|
||||
$SOAP::WSDL::XSD::Typelib::Builtin::anySimpleType::___value
|
||||
->{ $$current } = $characters
|
||||
if defined $characters && defined $current; # =~m{ [^\s] }xms;
|
||||
}
|
||||
|
||||
# empty characters
|
||||
$characters = q{};
|
||||
|
||||
# stop believing we're a leaf node
|
||||
$_leaf = 0;
|
||||
|
||||
# return if there's only one elment - can't set it in parent ;-)
|
||||
# but set as root element if we don't have one already.
|
||||
if (not defined $list->[-1]) {
|
||||
$self->{ data } = $current if (not exists $self->{ data });
|
||||
return;
|
||||
};
|
||||
|
||||
# set appropriate attribute in last element
|
||||
# multiple values must be implemented in base class
|
||||
# TODO check if hash access is faster
|
||||
# $_method = "add_$_localname";
|
||||
$_method = "add_$_[1]";
|
||||
#
|
||||
# fixup XML names for perl names
|
||||
#
|
||||
$_method =~s{\.}{__}xg;
|
||||
$_method =~s{\-}{_}xg;
|
||||
$list->[-1]->$_method( $current );
|
||||
|
||||
$current = pop @$list; # step up in object hierarchy
|
||||
|
||||
return;
|
||||
}
|
||||
);
|
||||
|
||||
return $parser;
|
||||
}
|
||||
|
||||
sub get_header {
|
||||
return $_[0]->{ header };
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,66 @@
|
|||
package ONVIF::Deserializer::XSD;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base qw(SOAP::WSDL::Deserializer::XSD);
|
||||
|
||||
use SOAP::WSDL::SOAP::Typelib::Fault11;
|
||||
use ONVIF::Deserializer::MessageParser;
|
||||
|
||||
use SOAP::WSDL::Factory::Deserializer;
|
||||
|
||||
SOAP::WSDL::Factory::Deserializer->register('1.1', __PACKAGE__ );
|
||||
SOAP::WSDL::Factory::Deserializer->register('1.2', __PACKAGE__ );
|
||||
|
||||
## we get the soap version from the message parser
|
||||
my %soap_version_of :ATTR( :default<()>);
|
||||
|
||||
|
||||
sub soap_version {
|
||||
my ($self) = @_;
|
||||
if($SOAP::WSDL::Deserializer::XSD::parser_of{ident $self}) {
|
||||
return $SOAP::WSDL::Deserializer::XSD::parser_of{ident $self}->soap_version();
|
||||
}
|
||||
return '';
|
||||
}
|
||||
|
||||
sub deserialize {
|
||||
my ($self, $content) = @_;
|
||||
|
||||
my $parser = $SOAP::WSDL::Deserializer::XSD::parser_of{ ${ $self } };
|
||||
if(not $parser) {
|
||||
$parser = ONVIF::Deserializer::MessageParser->new({
|
||||
strict => $SOAP::WSDL::Deserializer::XSD::strict_of{ ${ $self } }
|
||||
});
|
||||
$SOAP::WSDL::Deserializer::XSD::parser_of{ ${ $self } } = $parser;
|
||||
}
|
||||
|
||||
$parser->class_resolver(
|
||||
$self->SOAP::WSDL::Deserializer::XSD::get_class_resolver() );
|
||||
eval { $parser->parse_string( $content ) };
|
||||
if ($@) {
|
||||
return $self->generate_fault({
|
||||
code => 'SOAP-ENV:Server',
|
||||
role => 'urn:localhost',
|
||||
message => "Error deserializing message: $@. \n"
|
||||
. "Message was: \n$content"
|
||||
});
|
||||
}
|
||||
return ( $parser->get_data(),
|
||||
$parser->get_header() );
|
||||
}
|
||||
|
||||
sub generate_fault {
|
||||
my ($self, $args_from_ref) = @_;
|
||||
return SOAP::WSDL::SOAP::Typelib::Fault11->new({
|
||||
faultcode => $args_from_ref->{ code } || 'SOAP-ENV:Client',
|
||||
faultactor => $args_from_ref->{ role } || 'urn:localhost',
|
||||
faultstring => $args_from_ref->{ message } || "Unknown error"
|
||||
});
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,177 @@
|
|||
#!/usr/bin/perl -w
|
||||
package ONVIF::Serializer::Base;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
# =========================================================================
|
||||
|
||||
use Class::Std::Fast::Storable;
|
||||
use Scalar::Util qw(blessed);
|
||||
|
||||
require SOAP::WSDL::Factory::Serializer;
|
||||
|
||||
## require SOAP::Constants;
|
||||
use constant URI_1999_SCHEMA_XSD => "http://www.w3.org/1999/XMLSchema";
|
||||
use constant URI_1999_SCHEMA_XSI => "http://www.w3.org/1999/XMLSchema-instance";
|
||||
use constant URI_2000_SCHEMA_XSD => "http://www.w3.org/2000/10/XMLSchema";
|
||||
use constant URI_2000_SCHEMA_XSI => "http://www.w3.org/2000/10/XMLSchema-instance";
|
||||
use constant URI_2001_SCHEMA_XSD => "http://www.w3.org/2001/XMLSchema";
|
||||
use constant URI_2001_SCHEMA_XSI => "http://www.w3.org/2001/XMLSchema-instance";
|
||||
use constant URI_LITERAL_ENC => "";
|
||||
use constant URI_SOAP11_ENC => "http://schemas.xmlsoap.org/soap/encoding/";
|
||||
use constant URI_SOAP11_ENV => "http://schemas.xmlsoap.org/soap/envelope/";
|
||||
use constant URI_SOAP11_NEXT_ACTOR => "http://schemas.xmlsoap.org/soap/actor/next";
|
||||
use constant URI_SOAP12_ENC => "http://www.w3.org/2003/05/soap-encoding";
|
||||
use constant URI_SOAP12_ENV => "http://www.w3.org/2003/05/soap-envelope";
|
||||
use constant URI_SOAP12_NOENC => "http://www.w3.org/2003/05/soap-envelope/encoding/none";
|
||||
use constant URI_SOAP12_NEXT_ACTOR => "http://www.w3.org/2003/05/soap-envelope/role/next";
|
||||
|
||||
|
||||
my %soap_version_of :ATTR( :default<()>);
|
||||
|
||||
my $XML_INSTANCE_NS = 'http://www.w3.org/2001/XMLSchema-instance';
|
||||
|
||||
sub soap_version
|
||||
{
|
||||
my ($self) = @_;
|
||||
$soap_version_of{ident $self};
|
||||
}
|
||||
|
||||
sub set_soap_version
|
||||
{
|
||||
my ($self, $version) = @_;
|
||||
if(! (($version eq '1.1') or ($version eq '1.2')) ) {
|
||||
warn "Undefined SOAP version \'$version\'";
|
||||
return;
|
||||
}
|
||||
#print "using SOAP $version\n";
|
||||
$soap_version_of{ident $self} = $version;
|
||||
}
|
||||
|
||||
|
||||
sub serialize {
|
||||
my ($self, $args_of_ref) = @_;
|
||||
|
||||
my $SOAP_NS;
|
||||
if($self->soap_version() eq '1.2') {
|
||||
$SOAP_NS = URI_SOAP12_ENV;
|
||||
}
|
||||
else {
|
||||
$SOAP_NS = URI_SOAP11_ENV;
|
||||
}
|
||||
|
||||
my $opt = $args_of_ref->{ options };
|
||||
|
||||
if (not $opt->{ namespace }->{ $SOAP_NS })
|
||||
{
|
||||
$opt->{ namespace }->{ $SOAP_NS } = 'SOAP-ENV';
|
||||
}
|
||||
|
||||
if (not $opt->{ namespace }->{ $XML_INSTANCE_NS })
|
||||
{
|
||||
$opt->{ namespace }->{ $XML_INSTANCE_NS } = 'xsi';
|
||||
}
|
||||
|
||||
my $soap_prefix = $opt->{ namespace }->{ $SOAP_NS };
|
||||
|
||||
# envelope start with namespaces
|
||||
my $xml = "<$soap_prefix\:Envelope ";
|
||||
|
||||
while (my ($uri, $prefix) = each %{ $opt->{ namespace } })
|
||||
{
|
||||
$xml .= "xmlns:$prefix=\"$uri\" ";
|
||||
}
|
||||
#
|
||||
# add namespace for user-supplied prefix if needed
|
||||
$xml .= "xmlns:$opt->{prefix}=\"" . $args_of_ref->{ body }->get_xmlns() . "\" "
|
||||
if $opt->{prefix};
|
||||
|
||||
# TODO insert encoding
|
||||
$xml.='>';
|
||||
$xml .= $self->serialize_header($args_of_ref->{ method }, $args_of_ref->{ header }, $opt);
|
||||
$xml .= $self->serialize_body($args_of_ref->{ method }, $args_of_ref->{ body }, $opt);
|
||||
$xml .= '</' . $soap_prefix .':Envelope>';
|
||||
|
||||
return $xml;
|
||||
}
|
||||
|
||||
sub serialize_header {
|
||||
my ($self, $method, $data, $opt) = @_;
|
||||
|
||||
my $SOAP_NS;
|
||||
if($self->soap_version() eq '1.2') {
|
||||
$SOAP_NS = URI_SOAP12_ENV;
|
||||
}
|
||||
else {
|
||||
$SOAP_NS = URI_SOAP11_ENV;
|
||||
}
|
||||
|
||||
# header is optional. Leave out if there's no header data
|
||||
return q{} if not $data;
|
||||
return join ( q{},
|
||||
"<$opt->{ namespace }->{ $SOAP_NS }\:Header>",
|
||||
blessed $data ? $data->serialize_qualified : (),
|
||||
"</$opt->{ namespace }->{ $SOAP_NS }\:Header>",
|
||||
);
|
||||
}
|
||||
|
||||
sub serialize_body {
|
||||
my ($self, $method, $data, $opt) = @_;
|
||||
|
||||
my $SOAP_NS;
|
||||
if($self->soap_version() eq '1.2') {
|
||||
$SOAP_NS = URI_SOAP12_ENV;
|
||||
}
|
||||
else {
|
||||
$SOAP_NS = URI_SOAP11_ENV;
|
||||
}
|
||||
|
||||
# TODO This one wipes out the old class' XML name globally
|
||||
# Fix in some more appropriate place...
|
||||
$data->__set_name("$opt->{prefix}:" . $data->__get_name() ) if $opt->{prefix};
|
||||
|
||||
# Body is NOT optional. Serialize to empty body
|
||||
# if we have no data.
|
||||
return join ( q{},
|
||||
"<$opt->{ namespace }->{ $SOAP_NS }\:Body>",
|
||||
defined $data
|
||||
? ref $data eq 'ARRAY'
|
||||
? join q{}, map { blessed $_ ? $_->serialize_qualified() : () } @{ $data }
|
||||
: blessed $data
|
||||
? $opt->{prefix}
|
||||
? $data->serialize()
|
||||
: $data->serialize_qualified()
|
||||
: ()
|
||||
: (),
|
||||
"</$opt->{ namespace }->{ $SOAP_NS }\:Body>",
|
||||
);
|
||||
}
|
||||
|
||||
# =========================================================================
|
||||
|
||||
|
||||
1;
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Copy of SOAP:WSDL::Serializer::XSD adapted
|
||||
|
||||
=head1 LICENSE AND COPYRIGHT
|
||||
|
||||
This file was adapted from a part of SOAP-WSDL. You may
|
||||
distribute/modify it under the same terms as perl itself
|
||||
|
||||
=head1 REPOSITORY INFORMATION
|
||||
|
||||
$Rev: 851 $
|
||||
$LastChangedBy: kutterma $
|
||||
$Id: XSD.pm 851 2009-05-15 22:45:18Z kutterma $
|
||||
$HeadURL: https://soap-wsdl.svn.sourceforge.net/svnroot/soap-wsdl/SOAP-WSDL/trunk/lib/SOAP/WSDL/Serializer/XSD.pm $
|
||||
|
||||
=cut
|
||||
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
#!/usr/bin/perl -w
|
||||
package ONVIF::Serializer::SOAP11;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base qw(ONVIF::Serializer::Base);
|
||||
|
||||
use SOAP::WSDL::Factory::Serializer;
|
||||
|
||||
SOAP::WSDL::Factory::Serializer->register( '1.1' , __PACKAGE__ );
|
||||
|
||||
sub BUILD
|
||||
{
|
||||
my ($self, $ident, $args_ref) = @_;
|
||||
# $soapversion_of{ $ident } = '1.1';
|
||||
$self->set_soap_version('1.1');
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
#!/usr/bin/perl -w
|
||||
package ONVIF::Serializer::SOAP12;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base qw(ONVIF::Serializer::Base);
|
||||
|
||||
use SOAP::WSDL::Factory::Serializer;
|
||||
|
||||
SOAP::WSDL::Factory::Serializer->register( '1.2' , __PACKAGE__ );
|
||||
|
||||
sub BUILD
|
||||
{
|
||||
my ($self, $ident, $args_ref) = @_;
|
||||
# $soapversion_of{ $ident } = '1.2';
|
||||
$self->set_soap_version('1.2');
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -31,9 +31,9 @@ use Time::HiRes qw( usleep );
|
|||
|
||||
use version; our $VERSION = qv('1.00.00');
|
||||
|
||||
# 50 times 100 msec = 5sec timeout
|
||||
use constant WAIT_TIME => 100;
|
||||
use constant WAIT_COUNT => 50;
|
||||
# 20 times 200 msec = 4sec timeout
|
||||
use constant WAIT_TIME => 200.0;
|
||||
use constant WAIT_COUNT => 20;
|
||||
|
||||
SOAP::WSDL::Factory::Transport->register( 'soap.udp' => __PACKAGE__ );
|
||||
|
||||
|
|
@ -53,6 +53,13 @@ SUBFACTORY: {
|
|||
}
|
||||
}
|
||||
|
||||
# override to receive more than one response
|
||||
sub _notify_response
|
||||
{
|
||||
# my ($transport, $response) = @_;
|
||||
|
||||
}
|
||||
|
||||
sub send_multi() {
|
||||
my ($self, $address, $port, $data) = @_;
|
||||
|
||||
|
|
@ -74,10 +81,15 @@ sub receive_multi() {
|
|||
LocalPort=>$port, ReuseAddr=>1);
|
||||
$socket->mcast_add($address);
|
||||
|
||||
$socket->recv($data, 9999);
|
||||
my $readbits = '';
|
||||
vec($readbits, $socket->fileno, 1) = 1;
|
||||
|
||||
if(select($readbits, undef, undef, WAIT_TIME/1000)) {
|
||||
$socket->recv($data, 9999);
|
||||
return $data;
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub receive_uni() {
|
||||
my ($self, $address, $port, $localaddr) = @_;
|
||||
|
|
@ -88,10 +100,15 @@ sub receive_uni() {
|
|||
|
||||
$socket->mcast_add($address);
|
||||
|
||||
$socket->recv($data, 9999);
|
||||
my $readbits = '';
|
||||
vec($readbits, $socket->fileno, 1) = 1;
|
||||
|
||||
if(select($readbits, undef, undef, WAIT_TIME/1000)) {
|
||||
$socket->recv($data, 9999);
|
||||
return $data;
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub send_receive {
|
||||
my ($self, %parameters) = @_;
|
||||
|
|
@ -107,22 +124,24 @@ sub send_receive {
|
|||
|
||||
my $localaddr = $self->get_local_addr();
|
||||
|
||||
my $response;
|
||||
my ($response, $last_response);
|
||||
my $wait = WAIT_COUNT;
|
||||
while ($wait) {
|
||||
while ( $wait >= 0 ) {
|
||||
if($localaddr) {
|
||||
if($response = $self->receive_uni($address, $port, $localaddr)) {
|
||||
last;
|
||||
$last_response = $response;
|
||||
$self->_notify_response($response);
|
||||
}
|
||||
$wait --;
|
||||
}
|
||||
if($response = $self->receive_multi($address, $port)) {
|
||||
last;
|
||||
$last_response = $response;
|
||||
$self->_notify_response($response);
|
||||
}
|
||||
msleep(WAIT_TIME);
|
||||
$wait --;
|
||||
}
|
||||
|
||||
if($response) {
|
||||
if($last_response) {
|
||||
$self->code();
|
||||
$self->message();
|
||||
$self->is_success(1);
|
||||
|
|
@ -134,7 +153,7 @@ sub send_receive {
|
|||
$self->is_success(0);
|
||||
$self->status('TIMEOUT');
|
||||
}
|
||||
return $response;
|
||||
return $last_response;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -30,19 +30,25 @@ use Digest::SHA1;
|
|||
use MIME::Base64;
|
||||
|
||||
|
||||
use base qw( SOAP::WSDL::Serializer::XSD );
|
||||
use base qw( ONVIF::Serializer::Base );
|
||||
|
||||
use version; our $VERSION = qv('1.00.00');
|
||||
|
||||
my $SOAP_NS = 'http://schemas.xmlsoap.org/soap/envelope/';
|
||||
my $XML_INSTANCE_NS = 'http://www.w3.org/2001/XMLSchema-instance';
|
||||
|
||||
use constant URI_SOAP11_ENV => "http://schemas.xmlsoap.org/soap/envelope/";
|
||||
use constant URI_SOAP12_ENV => "http://www.w3.org/2003/05/soap-envelope";
|
||||
|
||||
#SOAP::WSDL::Factory::Serializer->register( '1.1' , __PACKAGE__ );
|
||||
|
||||
my %username_of :ATTR(:name<username> :default<()>);
|
||||
my %password_of :ATTR(:name<password> :default<()>);
|
||||
|
||||
#sub BUILD
|
||||
#{
|
||||
# my ($self, $ident, $args_ref) = @_;
|
||||
# $soapversion_of{ $ident } = '1.2';
|
||||
#}
|
||||
|
||||
|
||||
SUBFACTORY: {
|
||||
for (qw(username password)) {
|
||||
my $setter = "set_$_";
|
||||
|
|
@ -122,6 +128,11 @@ sub security_header {
|
|||
sub serialize_header() {
|
||||
my ($self, $method, $data, $opt) = @_;
|
||||
|
||||
my $SOAP_NS = URI_SOAP11_ENV;
|
||||
if($self->soap_version() eq '1.2') {
|
||||
$SOAP_NS = URI_SOAP12_ENV;
|
||||
}
|
||||
|
||||
# header is optional. Leave out if there's no header data
|
||||
return join ( q{},
|
||||
"<$opt->{ namespace }->{ $SOAP_NS }\:Header>",
|
||||
|
|
|
|||
|
|
@ -39,28 +39,81 @@ require WSDiscovery::TransportUDP;
|
|||
my $client;
|
||||
|
||||
# =========================================================================
|
||||
# internal functions
|
||||
|
||||
sub discover
|
||||
sub deserialize_message
|
||||
{
|
||||
my $svc_discover = WSDiscovery::Interfaces::WSDiscovery::WSDiscoveryPort->new();
|
||||
my ($wsdl_client, $response) = @_;
|
||||
|
||||
my $result = $svc_discover->ProbeOp(
|
||||
{ # WSDiscovery::Types::ProbeType
|
||||
Types => { 'dn:NetworkVideoTransmitter', 'tds:Device' }, # QNameListType
|
||||
Scopes => { value => '' },
|
||||
},,
|
||||
);
|
||||
die $result if not $result;
|
||||
# print $result;
|
||||
# copied and adapted from SOAP::WSDL::Client
|
||||
|
||||
foreach my $xaddr (split ' ', $result->get_ProbeMatch()->get_XAddrs()) {
|
||||
# get deserializer
|
||||
my $deserializer = $wsdl_client->get_deserializer();
|
||||
|
||||
if(! $deserializer) {
|
||||
$deserializer = SOAP::WSDL::Factory::Deserializer->get_deserializer({
|
||||
soap_version => $wsdl_client->get_soap_version(),
|
||||
%{ $wsdl_client->get_deserializer_args() },
|
||||
});
|
||||
}
|
||||
# set class resolver if serializer supports it
|
||||
$deserializer->set_class_resolver( $wsdl_client->get_class_resolver() )
|
||||
if ( $deserializer->can('set_class_resolver') );
|
||||
|
||||
# Try deserializing response - there may be some,
|
||||
# even if transport did not succeed (got a 500 response)
|
||||
if ( $response ) {
|
||||
# as our faults are false, returning a success marker is the only
|
||||
# reliable way of determining whether the deserializer succeeded.
|
||||
# Custom deserializers may return an empty list, or undef,
|
||||
# and $@ is not guaranteed to be undefined.
|
||||
my ($success, $result_body, $result_header) = eval {
|
||||
(1, $deserializer->deserialize( $response ));
|
||||
};
|
||||
if (defined $success) {
|
||||
return wantarray
|
||||
? ($result_body, $result_header)
|
||||
: $result_body;
|
||||
}
|
||||
elsif (blessed $@) { #}&& $@->isa('SOAP::WSDL::SOAP::Typelib::Fault11')) {
|
||||
return $@;
|
||||
}
|
||||
else {
|
||||
return $deserializer->generate_fault({
|
||||
code => 'soap:Server',
|
||||
role => 'urn:localhost',
|
||||
message => "Error deserializing message: $@. \n"
|
||||
. "Message was: \n$response"
|
||||
});
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
sub interpret_messages
|
||||
{
|
||||
my ($svc_discover, @responses, %services) = @_;
|
||||
|
||||
foreach my $response ( @responses ) {
|
||||
|
||||
my $result = deserialize_message($svc_discover, $response);
|
||||
next if not $result;
|
||||
|
||||
my $xaddr;
|
||||
foreach my $l_xaddr (split ' ', $result->get_ProbeMatch()->get_XAddrs()) {
|
||||
# find IPv4 address
|
||||
if($xaddr =~ m|//[0-9]+\.[0-9]+\.[0-9]+\.[0-9]+/|) {
|
||||
print $xaddr . ", ";
|
||||
if($l_xaddr =~ m|//[0-9]+\.[0-9]+\.[0-9]+\.[0-9]+/|) {
|
||||
$xaddr = $l_xaddr;
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
# ignore multiple responses from one service
|
||||
next if defined $services{$xaddr};
|
||||
$services{$xaddr} = 1;
|
||||
|
||||
print "$xaddr, " . $svc_discover->get_soap_version() . ", ";
|
||||
|
||||
print "(";
|
||||
my $scopes = $result->get_ProbeMatch()->get_Scopes();
|
||||
my $count = 0;
|
||||
|
|
@ -75,6 +128,57 @@ sub discover
|
|||
}
|
||||
print ")\n";
|
||||
}
|
||||
}
|
||||
|
||||
# =========================================================================
|
||||
# functions
|
||||
|
||||
sub discover
|
||||
{
|
||||
## collect all responses
|
||||
my @responses = ();
|
||||
|
||||
no warnings 'redefine';
|
||||
|
||||
*WSDiscovery::TransportUDP::_notify_response = sub {
|
||||
my ($transport, $response) = @_;
|
||||
push @responses, $response;
|
||||
};
|
||||
|
||||
## try both soap versions
|
||||
my %services;
|
||||
|
||||
my $svc_discover = WSDiscovery::Interfaces::WSDiscovery::WSDiscoveryPort->new({
|
||||
# no_dispatch => '1',
|
||||
});
|
||||
$svc_discover->set_soap_version('1.1');
|
||||
|
||||
my $result = $svc_discover->ProbeOp(
|
||||
{ # WSDiscovery::Types::ProbeType
|
||||
Types => { 'dn:NetworkVideoTransmitter', 'tds:Device' }, # QNameListType
|
||||
Scopes => { value => '' },
|
||||
},,
|
||||
);
|
||||
# print $result . "\n";
|
||||
|
||||
interpret_messages($svc_discover, \@responses, \%services);
|
||||
@responses = ();
|
||||
|
||||
$svc_discover = WSDiscovery::Interfaces::WSDiscovery::WSDiscoveryPort->new({
|
||||
# no_dispatch => '1',
|
||||
});
|
||||
$svc_discover->set_soap_version('1.2');
|
||||
|
||||
$result = $svc_discover->ProbeOp(
|
||||
{ # WSDiscovery::Types::ProbeType
|
||||
Types => { 'dn:NetworkVideoTransmitter', 'tds:Device' }, # QNameListType
|
||||
Scopes => { value => '' },
|
||||
},,
|
||||
);
|
||||
# print $result . "\n";
|
||||
|
||||
interpret_messages($svc_discover, @responses, \%services);
|
||||
}
|
||||
|
||||
|
||||
sub profiles
|
||||
|
|
@ -144,10 +248,9 @@ sub metadata
|
|||
die $result if not $result;
|
||||
print $result . "\n";
|
||||
|
||||
$result = $client->get_endpoint('analytics')->GetServiceCapabilities( { } ,, );
|
||||
die $result if not $result;
|
||||
print $result . "\n";
|
||||
|
||||
# $result = $client->get_endpoint('analytics')->GetServiceCapabilities( { } ,, );
|
||||
# die $result if not $result;
|
||||
# print $result . "\n";
|
||||
|
||||
}
|
||||
|
||||
|
|
@ -162,10 +265,13 @@ if($action eq "probe") {
|
|||
else {
|
||||
# all other actions need URI and credentials
|
||||
my $url_svc_device = shift;
|
||||
my $soap_version = shift;
|
||||
my $username = shift;
|
||||
my $password = shift;
|
||||
|
||||
$client = ONVIF::Client->new( { 'url_svc_device' => $url_svc_device } );
|
||||
$client = ONVIF::Client->new( {
|
||||
'url_svc_device' => $url_svc_device,
|
||||
'soap_version' => $soap_version } );
|
||||
|
||||
$client->set_credentials($username, $password, 1);
|
||||
|
||||
|
|
|
|||
|
|
@ -47,18 +47,20 @@ function probeCameras( $localIp )
|
|||
foreach ( $lines as $line )
|
||||
{
|
||||
$line = rtrim( $line );
|
||||
if ( preg_match( '|^(.+),\s\((.*)\)$|', $line, $matches ) )
|
||||
if ( preg_match( '|^(.+),(.+),\s\((.*)\)$|', $line, $matches ) )
|
||||
{
|
||||
$device_ep = $matches[1];
|
||||
$soapversion = $matches[2];
|
||||
$camera = array(
|
||||
'model' => "Unknown ONVIF Camera",
|
||||
'monitor' => array(
|
||||
'Function' => "Monitor",
|
||||
'Type' => 'Ffmpeg',
|
||||
'Host' => $device_ep,
|
||||
'SOAP' => $soapversion,
|
||||
),
|
||||
);
|
||||
foreach ( preg_split('|,\s*|', $matches[2]) as $attr_val ) {
|
||||
foreach ( preg_split('|,\s*|', $matches[3]) as $attr_val ) {
|
||||
if( preg_match( '|(.+)=\'(.*)\'|', $attr_val, $tokens ) )
|
||||
{
|
||||
if($tokens[1] == "hardware") {
|
||||
|
|
@ -80,11 +82,11 @@ function probeCameras( $localIp )
|
|||
return( $cameras );
|
||||
}
|
||||
|
||||
function probeProfiles( $device_ep, $username, $password )
|
||||
function probeProfiles( $device_ep, $soapversion, $username, $password )
|
||||
{
|
||||
$profiles = array();
|
||||
$count = 0;
|
||||
if ( $lines = @execONVIF( "profiles $device_ep $username $password" ) )
|
||||
if ( $lines = @execONVIF( "profiles $device_ep $soapversion $username $password" ) )
|
||||
{
|
||||
foreach ( $lines as $line )
|
||||
{
|
||||
|
|
@ -230,7 +232,7 @@ else if($_REQUEST['step'] == "2")
|
|||
|
||||
//print $monitor['Host'].", ".$_REQUEST['username'].", ".$_REQUEST['password']."<br/>";
|
||||
|
||||
$detprofiles = probeProfiles( $monitor['Host'], $_REQUEST['username'], $_REQUEST['password']);
|
||||
$detprofiles = probeProfiles( $monitor['Host'], $monitor['SOAP'], $_REQUEST['username'], $_REQUEST['password']);
|
||||
foreach ( $detprofiles as $profile )
|
||||
{
|
||||
$monitor = $camera['monitor'];
|
||||
|
|
|
|||
Loading…
Reference in New Issue