not_ results from the CPAN

ASNMTAP


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

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' );
  my @urls = @$urls_ar;

  foreach my $url ( @urls ) {
    &_dumpValue ( $url, $object .': Request record is not a hash.' ) if ( ref $url ne 'HASH' );
    my @keys = keys %$url;

    foreach my $key ( @keys ) {
      unless ( exists Field_Refs->{$key} ) {
        warn "Expected keys: ", join " ", keys %{ (Field_Refs) };
        &_dumpValue ( $url, $object .": Unexpected key \"$key\" in record." );
      }

      my $ref_type = '';

      if ( ($ref_type = ref $url->{$key}) && ( $ref_type ne Field_Refs->{$key}{type} ) ) {
        warn "Expected key \"$key\" to be ", Field_Refs->{$key}{type} ? Field_Refs->{$key}{type} .' ref' : 'non ref', "\n";
        &_dumpValue ( $url, $object .": Field \"$key\" has wrong reference type" );
      }

      if ( ! ref $url->{$key} and Field_Refs->{$key}{is_ref} ) {
        warn "Expected key \"$key\" to be ", Field_Refs->{$key}{type} ? Field_Refs->{$key}{type} .' ref' : 'non ref', "\n";
        &_dumpValue ( $url, $object .": Key \"$key\" not a  reference" );
      }

      if ( $url->{$key} eq '' ) {
        warn "Expected key \"$key\" is empty\n";
        &_dumpValue ( $url, $object .": Key \"$key\" is empty" );
      }
    }
  }

  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.

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

      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} );
    splice ( @query_string, scalar @query_string, 0, @nvp );
  }

  if ( $method eq 'GET' ) {
    while ( my ($name, $val) = splice(@query_string, 0, 2) ) { $query_string .= "$name=$val&"; }

( run in 2.365 seconds using v1.01-cache-2.11-cpan-437f7b0c052 )