view release on metacpan or  search on metacpan

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

  # $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.

  # 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' );