view release on metacpan or  search on metacpan

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

# ----------------------------------------------------------------------------------------------------------
# © Copyright 2003-2011 by Alex Peeters [alex.peeters@citap.be]
# ----------------------------------------------------------------------------------------------------------
# 2011/mm/dd, v3.002.003, package ASNMTAP::Asnmtap::Plugins::WebTransact
# ----------------------------------------------------------------------------------------------------------

package ASNMTAP::Asnmtap::Plugins::WebTransact;

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

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 CGI::Carp qw(fatalsToBrowser set_message cluck);

use HTTP::Request::Common qw(GET POST HEAD);
use HTTP::Cookies;

use LWP::Debug;
use LWP::UserAgent;

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

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

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

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

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

use constant FALSE => 0;
use constant TRUE  => ! FALSE;

use constant Field_Refs	=> {
                             Method	        => { is_ref => FALSE, type => ''      },
                             Url            => { is_ref => FALSE, type => ''      },
                             Qs_var	        => { is_ref => TRUE,  type => 'ARRAY' },
                             Qs_fixed	      => { is_ref => TRUE,  type => 'ARRAY' },
                             Exp            => { is_ref => FALSE, type => 'ARRAY' },
                             Exp_Fault	    => { is_ref => FALSE, type => ''      },
                             Exp_Return     => { is_ref => TRUE,  type => 'HASH'  },
                             Msg            => { is_ref => FALSE, type => ''      },
                             Msg_Fault	    => { is_ref => FALSE, type => ''      },
                             Timeout        => { is_ref => FALSE, type => undef   },
                             Perfdata_Label => { is_ref => FALSE, type => undef   }
                           };

my (%returns, %downloaded, $ua);
keys %downloaded = 128;

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

sub _handleHttpdErrors { print "<hr><h1>ASNMTAP::Asnmtap::Plugins::WebTransact It's not a bug, it's a feature!</h1><p>Error: $_[0]</p><hr>"; }

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

set_message ( \&_handleHttpdErrors );

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

sub _error_message { $_[0] =~ s/\n/ /g; $_[0]; }

# = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =

sub new {
  my ($object, $asnmtapInherited, $urls_ar) = @_;

  # $urls_ar is a ref to a list of hashes (representing a request record) in a partic format.

  # If a hash is __not__ in that format it's much better to cluck since it is
  # hard to interpret 'not an array ref' messages (from check::_make_request) caused
  # by mis spelled or mistaken field names.

  &_dumpValue ( $asnmtapInherited, $object .': attribute asnmtapInherited is missing.' ) unless ( defined $asnmtapInherited );

  &_dumpValue ( $urls_ar, $object .': URL list is not an array reference.' ) if ( ref $urls_ar ne 'ARRAY' );

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

  my %defaults = ( custom           => undef,
                   perfdataLabel    => undef,
                   newAgent         => undef,
                   timeout          => undef,
                   triesTiming      => '1,3,15',
                   triesCodes       => '408,500,502,503,504',
                   openAppend       => TRUE,
                   cookies          => TRUE,
                   protocol         => TRUE,
                   keepAlive        => TRUE,
                   download_images  => FALSE,
                   fail_if_1        => TRUE );

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

  my $debug         = ${$self->{asnmtapInherited}}->getOptionsValue ( 'debug' );
  my $onDemand      = ${$self->{asnmtapInherited}}->getOptionsValue ( 'onDemand' );
  my $debugfile     = ${$self->{asnmtapInherited}}->getOptionsArgv ( 'debugfile' );
  my $openAppend    = $parms{openAppend};
  my $triesTiming   = $parms{triesTiming};
  my %triesCodesToDeterminate = map { $_ => 1 } ( $parms{triesCodes} =~ m<(\d+(?:\.\d+)*)>g );

  my $proxyServer   = ${$self->{asnmtapInherited}}->proxy ( 'server' );
  my $proxyUsername = ${$self->{asnmtapInherited}}->proxy ( 'username' );
  my $proxyPassword = ${$self->{asnmtapInherited}}->proxy ( 'password' );

  $self->{newAgent} = $parms{newAgent} if ( defined $parms{newAgent} and defined $ua );

  if ( $self->{newAgent} or ! defined $ua ) {
    $self->{newAgent} = 0;
    LWP::Debug::level('+') if ( $debug );

    if ( $parms{keepAlive} ) {
      $ua = LWP::UserAgent->new ( keep_alive => 1 );
    } else {
      $ua = LWP::UserAgent->new ( keep_alive => 0 );
    }

    $self->{ua} = $ua;
    $ua->agent ( ${$self->{asnmtapInherited}}->browseragent () );
    $ua->timeout ( ${$self->{asnmtapInherited}}->timeout () );

    $ua->default_headers->push_header ( 'Accept-Language' => 'no, en' );
    $ua->default_headers->push_header ( 'Accept-Charset'  => 'iso-8859-1,*,utf-8' );
    $ua->default_headers->push_header ( 'Accept-Encoding' => 'gzip, deflate' );

    $ua->default_headers->push_header ( 'Keep-Alive' => ${$self->{asnmtapInherited}}->timeout () ) if ( $parms{keepAlive} );
    $ua->default_headers->push_header ( 'Connection' => 'Keep-Alive' );

    if ( defined $proxyServer ) {
      $ua->default_headers->push_header ( 'Proxy-Connection' => 'Keep-Alive' );

      # don't use $ua->proxy ( ['http', 'https', 'ftp'] => $proxyServer ); or $ua->proxy ( 'https' => undef ) ;
      $ua->proxy ( ['http', 'ftp'] => $proxyServer );

      # do not proxy requests to the given domains. Calling no_proxy without any domains clears the list of domains.
      ( defined ${$self->{asnmtapInherited}}->proxy ( 'no' ) and ${$self->{asnmtapInherited}}->proxy ( 'no' ) ne '' ? $ua->no_proxy( @{ ${$self->{asnmtapInherited}}->proxy ( 'no' ) } ) : $ua->no_proxy( ) ) ;
    }

    $ua->cookie_jar ( HTTP::Cookies->new ) if ( $parms{cookies} );
  }

  if ( defined $parms{timeout} ) {
    $ua->timeout ( $parms{timeout} );
    $ua->default_headers->push_header ( 'Keep-Alive' => $parms{timeout} ) if ( $parms{keepAlive} );
  }

  my $returnCode = $parms{fail_if_1} ? $ERRORS{OK} : $ERRORS{CRITICAL};
  my ($response_as_content, $response, $found);

  my $startTime;

  if ( defined $parms{perfdataLabel} and $parms{perfdataLabel} ) {
    ${$self->{asnmtapInherited}}->setEndTime_and_getResponsTime ( ${$self->{asnmtapInherited}}->pluginValue ('endTime') );
    $startTime = ${$self->{asnmtapInherited}}->pluginValue ('endTime');
  }

  my $statusTimeout;

  foreach my $url_r ( @{ $self->{urls} } ) {
    if ( defined $url_r->{Timeout} ) {
      $statusTimeout = 1;
      $ua->timeout ( $url_r->{Timeout} );
      $ua->default_headers->push_header ( 'Keep-Alive' => $url_r->{Timeout} ) if ( $parms{keepAlive} );
    } elsif ( defined $statusTimeout ) {
      $statusTimeout = undef;

      if ( defined $parms{timeout} ) {
        $ua->timeout ( $parms{timeout} );
        $ua->default_headers->push_header ( 'Keep-Alive' => $parms{timeout} ) if ( $parms{keepAlive} );
      } else {
        $ua->timeout ( ${$self->{asnmtapInherited}}->timeout () );
        $ua->default_headers->push_header ( 'Keep-Alive' => ${$self->{asnmtapInherited}}->timeout () ) if ( $parms{keepAlive} );
      }
    }

    $self->{_KnownError} = undef;
    ${$self->{asnmtapInherited}}->setEndTime_and_getResponsTime ( ${$self->{asnmtapInherited}}->pluginValue ('endTime') );

    my $url = $url_r->{Url} ? $url_r->{Url} : &_next_url ($response, $response_as_content);
    my $request = $self->_make_request ( $url_r->{Method}, $url, $url_r->{Qs_var}, $url_r->{Qs_fixed}, $cgi_parm_vals_hr );
    $request->protocol ('HTTP/1.1') if ( $parms{protocol} );
    $request->proxy_authorization_basic ( $proxyUsername, $proxyPassword ) if ( defined $proxyServer && defined $proxyUsername && defined $proxyPassword );

    my $request_as_string = $request->as_string;
    print "\n", ref ($self), '::send_request: ', $request_as_string, "\n" if ( $debug );

    if ( defined $triesTiming and $triesTiming ) {
      my (@timing_tries) = ( $triesTiming =~ m<(\d+(?:\.\d+)*)>g );
      LWP::Debug::debug ('My retrial code policy is ['. join(' ', sort keys %triesCodesToDeterminate) .'].');
      LWP::Debug::debug ('My retrial timing policy is ['. $triesTiming .'].');
      my $timing_tries = 0;

      foreach my $pause_if_unsuccessful ( @timing_tries, undef ) {
        $response = $ua->request ($request);
        my $code = $response->code;
        my $message = $response->message;
        $message =~ s/\s+$//s;
        $timing_tries++;