view release on metacpan or  search on metacpan

lib/ASNMTAP/Asnmtap/Plugins/SOAP.pm  view on Meta::CPAN

# ----------------------------------------------------------------------------------------------------------
# © Copyright 2000-2011 by Alex Peeters [alex.peeters@citap.be]
# ----------------------------------------------------------------------------------------------------------
# 2011/mm/dd, v3.002.003, package ASNMTAP::Asnmtap::Plugins::SOAP Object-Oriented Perl
# ----------------------------------------------------------------------------------------------------------

# Class name  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
package ASNMTAP::Asnmtap::Plugins::SOAP;

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

use strict;
use warnings;           # Must be used in test mode only. This reduces a little process speed
#use diagnostics;       # Must be used in test mode only. This reduces a lot of process speed

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

use Carp qw(cluck);

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

use ASNMTAP::Asnmtap qw(%ERRORS %TYPE);

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

BEGIN {
  use Exporter ();

  @ASNMTAP::Asnmtap::Plugins::SOAP::ISA         = qw(Exporter ASNMTAP::Asnmtap);

  %ASNMTAP::Asnmtap::Plugins::SOAP::EXPORT_TAGS = ( ALL => [ qw(&get_soap_request) ] );

  @ASNMTAP::Asnmtap::Plugins::SOAP::EXPORT_OK   = ( @{ $ASNMTAP::Asnmtap::Plugins::SOAP::EXPORT_TAGS{ALL} } );

  $ASNMTAP::Asnmtap::Plugins::SOAP::VERSION     = do { my @r = (q$Revision: 3.002.003$ =~ /\d+/g); sprintf "%d."."%03d" x $#r, @r };
}

# Utility methods - - - - - - - - - - - - - - - - - - - - - - - - - - - -

sub get_soap_request {
  my %defaults = ( asnmtapInherited     => undef,
                   custom               => undef,
                   customArguments      => undef,
                   proxy                => undef,
                   credentials          => undef,
                   namespace            => undef,
                   registerNamespace    => undef,
                   method               => undef,
                   soapaction           => undef,
                   xmlContent           => undef,
                   params               => undef,
                   envprefix            => 'soapenv',
                   encprefix            => 'soapenc',
                   encodingStyle        => undef,
                   readable             => 1,
                   cookies              => undef,
                   perfdataLabel        => undef,

                   PATCH_HTTP_KEEPALIVE => 0,
                   WSRF                 => 0,

                   TYPE_ERROR_RETURN    => 'REPLACE'
				 );

  my %parms = (%defaults, @_);

  my $asnmtapInherited = $parms{asnmtapInherited};
  unless ( defined $asnmtapInherited ) { cluck ( 'ASNMTAP::Asnmtap::Plugins::SOAP: asnmtapInherited missing' ); exit $ERRORS{UNKNOWN} }

  unless ( defined $parms{proxy} ) {
    $$asnmtapInherited->pluginValues ( { stateValue => $ERRORS{UNKNOWN}, error => 'Missing SOAP parameter proxy' }, $TYPE{APPEND} );
    return ( $ERRORS{UNKNOWN} );
  }

  my $namespace = $parms{namespace};

  unless ( defined $namespace ) {
    $$asnmtapInherited->pluginValues ( { stateValue => $ERRORS{UNKNOWN}, error => 'Missing SOAP parameter namespace' }, $TYPE{APPEND} );
    return ( $ERRORS{UNKNOWN} );
  }

  my $registerNamespace = $parms{registerNamespace};

  if ( defined $registerNamespace ) {
    unless ( ref $registerNamespace eq 'HASH' ) {
      $$asnmtapInherited->pluginValues ( { stateValue => $ERRORS{UNKNOWN}, error => 'Missing SOAP parameter registerNamespace' }, $TYPE{APPEND} );
      return ( $ERRORS{UNKNOWN} );
    }
  }

  unless ( defined $parms{method} ) {
    $$asnmtapInherited->pluginValues ( { stateValue => $ERRORS{UNKNOWN}, error => 'Missing SOAP parameter method' }, $TYPE{APPEND} );
    return ( $ERRORS{UNKNOWN} );
  }

  my $soapaction = $parms{soapaction};

  my $xmlContent = $parms{xmlContent};

  my $params = $parms{params};

  my $readable = $parms{readable};

  my $envprefix = $parms{envprefix};

lib/ASNMTAP/Asnmtap/Plugins/SOAP.pm  view on Meta::CPAN

  my ($service, $alert, $error, $result);

  if ( $WSRF ) {
    if ( $debug >= 4 ) {
      eval "use WSRF::Lite +trace => 'all'";
    } elsif ($debug == 1) {
      eval "use WSRF::Lite +trace => qw( debug )";
    } else {
      eval "use WSRF::Lite";
    }

    $service = new WSRF::Lite
      -> wsaddress  ( WSRF::WS_Address->new()->Address( $parms{proxy} ) )
      -> autotype   ( 1 )
      -> readable   ( $readable )
      -> envprefix  ( $envprefix )
      -> encprefix  ( $encprefix )
      -> xmlschema  ( 'http://www.w3.org/2001/XMLSchema' )
      -> uri        ( $namespace )
      -> on_action  ( sub { my $uri = $_[0]; $uri =~ s/\/$//; my $method = (defined $soapaction ? ( $soapaction eq '' ? '' : $soapaction ) : $uri .'/'. $_[1]) } )
      -> on_fault   ( sub { } )
    ;
  } else {
    if ( $debug >= 4 ) {
      eval "use SOAP::Lite +trace => 'all'";
    } elsif ($debug == 1) {
      eval "use SOAP::Lite +trace => qw( debug )";
    } else {
      eval "use SOAP::Lite";
    }

    $service = new SOAP::Lite
      -> autotype   ( 1 )
      -> readable   ( $readable )
      -> envprefix  ( $envprefix )
      -> encprefix  ( $encprefix )
      -> xmlschema  ( 'http://www.w3.org/2001/XMLSchema' )
      -> uri        ( $namespace )
      -> on_action  ( sub { my $uri = $_[0]; $uri =~ s/\/$//; my $method = (defined $soapaction ? ( $soapaction eq '' ? '' : $soapaction ) : $uri .'/'. $_[1]) } )
      -> on_fault   ( sub { } )
    ;
  }

  $service->serializer->encodingStyle ( $encodingStyle ) if ( defined $encodingStyle );
  $SOAP::Constants::PATCH_HTTP_KEEPALIVE = $PATCH_HTTP_KEEPALIVE;

  if ( defined $parms{registerNamespace} ) {
    while ( my ($key, $value) = each( %{ $parms{registerNamespace} } ) ) {
      $service->serializer->register_ns($key, $value);
    }
  }

  if ( defined $proxySettings ) {
    $service->proxy ( $parms{proxy}, timeout => $timeout, proxy => ['http' => "http://$proxySettings"] );
  } else {
    $service->proxy ( $parms{proxy}, timeout => $timeout );
  }

  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

  $service->transport->credentials( @{$parms{credentials}} ) if ( defined $parms{credentials} );

  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # $service->proxy ( 'https://USERNAME:PASSWORD@secure.citap.be/authorization/hibye.cgi' );
  # or
  # $service->proxy ( 'https://secure.citap.be/authorization/hibye.cgi', credentials => [ 'secure.citap.be:443', "ASNMTAP's Authorization Access", 'USERNAME' => 'PASSWORD' ], timeout => $timeout );
  # or
  # $service->transport->credentials( 'secure.citap.be:443', "ASNMTAP's Authorization Access", 'USERNAME' => 'PASSWORD' );
  # or
  # use MIME::Base64;
  # $service->transport->http_request->header( 'Authorization' => 'Basic '. MIME::Base64::encode ( 'USERNAME' .':'. 'PASSWORD', '' ) );
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

  $service->transport->agent( $browseragent );
  $service->transport->timeout( $timeout );  

  use HTTP::Cookies;
  $service->transport->cookie_jar( HTTP::Cookies->new ) if ( $cookies );

  $service->transport->default_headers->push_header( 'Accept-Language' => "no, en" );
  $service->transport->default_headers->push_header( 'Accept-Charset'  => "iso-8859-1,*,utf-8" );
  $service->transport->default_headers->push_header( 'Accept-Encoding' => "gzip, deflate" );
 
  print "ASNMTAP::Asnmtap::Plugins::SOAP::get_soap_request: () -->\n" if ( $debug );
  $$asnmtapInherited->setEndTime_and_getResponsTime ( $$asnmtapInherited->pluginValue ('endTime') );

  my $som = (defined $params and $params ne '') ? (ref $params eq 'ARRAY' ? $service->call( $parms{method} => @$params ) : $service->call( $parms{method} => $params )) : $service->call( $parms{method} );

  my $responseTime = $$asnmtapInherited->setEndTime_and_getResponsTime ( $$asnmtapInherited->pluginValue ('endTime') );
  $$asnmtapInherited->appendPerformanceData ( "'". $parms{perfdataLabel} ."'=". $responseTime ."ms;;;;" );
  print "ASNMTAP::Asnmtap::Plugins::SOAP::get_soap_request: () <->\n" if ( $debug );

  my $returnCode = _soapCheckTransportStatus ($asnmtapInherited, $service, $TYPE_ERROR_RETURN, $debug);

  unless ( $returnCode ) {
    unless ( defined $som and defined $som->fault ) {
      $result = UNIVERSAL::isa($som => ($WSRF ? 'WSRF::SOM' : 'SOAP::SOM')) ? (wantarray ? $som->paramsall : $som->result) : $som;

      if ( $debug ) {
        for ( ref $result ) {
          /^REF$/ &&
            do { 
              for ( ref $$result ) {
                /^ARRAY$/ &&
                  do { print "ASNMTAP::Asnmtap::Plugins::SOAP::get_soap_request: REF ARRAY: @$$result\n"; last; };
                /^HASH$/ &&
                  do { print "ASNMTAP::Asnmtap::Plugins::SOAP::get_soap_request: REF HASH: "; while (my ($key, $value) = each %{ $$result } ) { print "$key => $value "; }; print "\n"; last; };
              }

              last;
            };
          /^ARRAY$/ &&
            do { print "ASNMTAP::Asnmtap::Plugins::SOAP::get_soap_request: ARRAY: @$result\n"; last; };
          /^HASH$/ &&
            do { print "ASNMTAP::Asnmtap::Plugins::SOAP::get_soap_request: HASH: "; while (my ($key, $value) = each %{ $result } ) { print "$key => $value "; }; print "\n"; last; };
          /^SCALAR$/ &&
            do { print "ASNMTAP::Asnmtap::Plugins::SOAP::get_soap_request: REF SCALAR: ", $$result, "\n"; last; };
          print "ASNMTAP::Asnmtap::Plugins::SOAP::get_soap_request: SCALAR: ", $result, "\n";
        }
      }

      if ( $returnCode == $ERRORS{OK} and defined $parms{custom} ) {
        my $root = $som->dataof ('/Envelope/Body');

        if ( defined $root ) {
          $returnCode = ( defined $parms{customArguments} ) ? $parms{custom}->($$asnmtapInherited, $som, $parms{customArguments}) : $parms{custom}->($$asnmtapInherited, $som);
        } else {
          print "ASNMTAP::Asnmtap::Plugins::SOAP::get_soap_request: Missing SOAP Envelope or Body", "\n" if ( $debug );