view release on metacpan or  search on metacpan

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

  }

  my $classname = ref ($object) || $object;
  my $accessor_stash_slot = $classname .'::'. 'get_urls';
  no strict 'refs';

  unless ( ref *$accessor_stash_slot{CODE} eq 'CODE' ) {
    foreach my $accessor ( qw(urls matches returns ua) ) {
      my $full_name = $classname .'::'. $accessor;

      *{$full_name} = sub { my $self = shift @_;
                            $self->{$accessor} = shift @_ if @_;
                            $self->{$accessor};
                          };

      foreach my $acc_pre (qw(get set)) {
        $full_name = $classname .'::'. $acc_pre .'_'. $accessor;
        *{$full_name} = $acc_pre eq 'get' ? sub { my $self = shift @_; $self->{$accessor} } : sub { my $self = shift @_; $self->{$accessor} = shift @_ };
      }
    }
  }

  bless { asnmtapInherited => $asnmtapInherited, urls => $urls_ar, matches => [], returns => {}, ua => undef, newAgent => 1, number_of_images_downloaded => 0, _unknownErrors => 0, _KnownError => undef, _timing_tries => 0 }, $classname;
  # The field urls contains a ref to a list of (hashes) records representing the web transaction.

  # self->_my_match() will update $self->{matches};
  # with the set of matches it finds by matching patterns with memory (ie patterns in paren) from
  # the Exp field against the request response.
  # An array ref to the array containing the matches is stored in the field 'matches'.

  # Qs_var = [ form_name_1 => 0, form_name_2 => 1 ..] will lead to a query_string like
  # form_name_1 = $matches[0] form_name_2 = $matches[1] .. in $self->_make_request() by
  # @matches = $self->matches(); and using 0, 1 etc as indices of @matches.
}

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

sub check {
  my ($self, $cgi_parm_vals_hr) = @_;

  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} ) {

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

      $self->{_unknownErrors}++;
      return ( $ERRORS{CRITICAL} );
    } elsif ( ! ($found = $self->_my_match ( $url_r->{Exp}, $response_as_content, 1 )) ) {
      my $exp_type = ref $url_r->{Exp};
      my $exp_str = $exp_type eq 'ARRAY' ? "@{$url_r->{Exp}}" : $url_r->{Exp};
      ${$self->{asnmtapInherited}}->pluginValues ( { stateValue => $ERRORS{CRITICAL}, alert => "'". $url_r->{Msg} ."' - '". $exp_str ."' not in response", error => &_error_message ( $request->method .' '. $request->uri ), result => $response_as_conte...
      $self->{_unknownErrors}++;
      return ( $ERRORS{CRITICAL} );
    } elsif (ref $url_r->{Exp} eq 'ARRAY') {
      my $exp_array = @{$url_r->{Exp}};

      if ( $exp_array != $found ) {
        ${$self->{asnmtapInherited}}->pluginValues ( { stateValue => $ERRORS{CRITICAL}, alert => "'". $url_r->{Msg} ."' - '". ( $exp_array - $found ) ."' element(s) not in response", error => &_error_message ( $request->method .' '. $request->uri ), ...
        $self->{_unknownErrors}++;
        return ( $ERRORS{CRITICAL} );
      }
    }

    if ( $parms{download_images} ) {
      my ($image_dl_nok, $image_dl_msg, $number_imgs_dl) = $self->_download_images ($response, \%parms, \%downloaded);

      if ( $image_dl_nok ) {
        ${$self->{asnmtapInherited}}->pluginValues ( { stateValue => $ERRORS{CRITICAL}, error => $image_dl_msg }, $TYPE{REPLACE} );
        $self->{_unknownErrors}++;
        return ( $ERRORS{CRITICAL} );
      }

      $self->{number_of_images_downloaded} += $number_imgs_dl;
    }
  }

  if ( defined $parms{perfdataLabel} and defined $startTime ) {
    my $responseTime = ${$self->{asnmtapInherited}}->setEndTime_and_getResponsTime ( $startTime );
    ${$self->{asnmtapInherited}}->appendPerformanceData ( "'". $parms{perfdataLabel} ."'=". $responseTime .'ms;;;;' );
  }

  ${$self->{asnmtapInherited}}->pluginValues ( { stateValue => $returnCode, alert => ( ( $parms{download_images} and ! $returnCode ) ? "downloaded $self->{number_of_images_downloaded} images" : undef ), error => ( $returnCode ? '?' : undef ), result ...
  return ( $returnCode );
}

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

sub _download_images {
  my ($self, $response, $parms_hr, $downloaded_hr) = @_;

  require HTML::LinkExtor;
  require URI::URL;
  URI::URL->import(qw(url));

  my @imgs = ();

  my $cb = sub {
    my ($tag, %attr) = @_;
    return if $tag ne 'img';           # we only look closer at <img ...>
    push (@imgs, $attr{src});
  };

  my $p = HTML::LinkExtor->new($cb);
  $p->parse($response->as_string);
  my $base = $response->base;
  my @imgs_abs = grep ! $downloaded_hr->{$_}++, map { my $x = url($_, $base)->abs; } @imgs;
  my @img_urls = map { Method => 'GET', Url => $_->as_string, Qs_var => [], Qs_fixed => [], Exp => '.', Exp_Fault => 'NeverInAnImage', Msg => '.', Msg_Fault => 'NeverInAnImage', Perfdata_Label => $_->as_string }, @imgs_abs;

  # url() returns an array ref containing the abs url and the base.
  if ( my $number_of_images_not_already_downloaded = scalar @img_urls ) {
    my $img_trx = __PACKAGE__->new( $self->{asnmtapInherited}, \@img_urls );
    my %image_dl_parms = (%$parms_hr, fail_if_1 => FALSE, download_images => FALSE);
    return ( $img_trx->check( {}, %image_dl_parms), 'Downloaded not all '. $number_of_images_not_already_downloaded .' images found in '. $response->base, $number_of_images_not_already_downloaded );
  } else {
    return ( $ERRORS{OK}, 'Downloaded all __zero__ images found in '. $response->base, 0 );
  }
}

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

sub _make_request {
  my ($self, $method, $url, $qs_var_ar, $qs_fixed_ar, $name_vals_hr) = @_;

  # $qs_var_ar is an array reference containing the name value pairs of any parameters whose
  # value is known only at run time

  # the format of $qs_var_ar is [cgi_parm_name => val, cg_parm_name => val ..]
  # where cgi_parm_name is the name of a fill out form parameter and val is a string used as a
  # key in %$name_vals_hr to get the value of the cgi_parameter.

  # eg [p_tm_number, tmno] has the parameter name 'p_tm_number' and val 'tmno'.

  # If $name_vals_hr = { tmno = > 1 }, the query_sring becomes p_tm_number=1

  # when the val is a digit, that digit is interpreted as a relative match in the last
  # set of matches found by ->_my_match eg

  # [p_tm_number => 1] means get the second match (from the last set of matches)
  # and use it as the value of p_tm_number.

  # If the value is a array ref eg [p_tm_number, [0, sub { $_[0] .'Blah' }]
  # then the query_string becomes p_tm_number => $ar->[1]( $name_vals{$ar->[0]} )

  # qs_fixed is an array_ref containing name value pairs

  my ($request, $content_type, @query_string, $query_string, @qs_var, @qs_fixed, %name_vals, @nvp);
  my @matches = @{ $self->matches() };
  @qs_var = @$qs_var_ar;
  @qs_fixed = @$qs_fixed_ar;
  %name_vals = %$name_vals_hr;

  # add the matches as (over the top if some of the name_val keys are eq '0', '1' ..) keys to  %name_vals
  @name_vals {0 .. $#matches} = @matches;
  @query_string = ();
  @nvp = ();
  $query_string = '';
  $content_type = 0; # 'application/x-www-form-urlencoded'

  while ( my ($name, $val) = splice(@qs_fixed, 0, 2) ) {
	  splice(@query_string, scalar @query_string, 0, ($name, $val));
    $content_type = 1 if ( ref $val eq 'ARRAY' );
  }

  # a cgi var name must be in qs_var for it's value to be changed (otherwise it doesn't get in the form query string)

  while ( my ($name, $val) = splice(@qs_var, 0, 2) ) {
    @nvp = ref $val eq 'ARRAY' ? ( $name, &{ $val->[1] }($name_vals{$val->[0]}) ) : ( $name, $name_vals{$val} );