lib/WWW/Mechanize/Script/Plugin/TextMatchTest.pm

   1 package WWW::Mechanize::Script::Plugin::TextMatchTest;
   2
   3 use strict;
   4 use warnings;
   5
   6 use parent qw(WWW::Mechanize::Script::Plugin);
   7
   8 # ABSTRACT: check for required/forbidden text in response
   9
  10 use Params::Util qw(_ARRAY0);
  11
  12 our $VERSION = '0.001_003';
  13
  14 use 5.014;
  15
  16 sub check_value_names
  17 {
  18     return qw(text_forbid text_require);
  19 }
  20
  21 sub check_response
  22 {
  23     my ( $self, $check, $mech ) = @_;
  24
  25     my $text_require = $self->get_check_value( $check, "text_require" );
  26     my $text_forbid  = $self->get_check_value( $check, "text_forbid" );
  27     my $ignore_case = $self->get_check_value_as_bool( $check, "ignore_case" );
  28     my $content = $mech->is_html() ? $mech->text() : $mech->content();
  29
  30     defined($text_require) and ref($text_require) ne "ARRAY" and $text_require = [$text_require];
  31     defined($text_forbid)  and ref($text_forbid)  ne "ARRAY" and $text_forbid  = [$text_forbid];
  32
  33     my @match_fails;
  34     my $code = 0;
  35     my $case_ign = $ignore_case ? "(?i)" : "";
  36     my @msg;
  37     foreach my $text_line ( @{$text_require} )
  38     {
  39         if ( $content !~ m/$case_ign\Q$text_line\E/ )
  40         {
  41             my $err_code = $self->get_check_value( $check, "text_require_code" ) // 1;
  42             $code = &{ $check->{compute_code} }( $code, $err_code );
  43             push( @match_fails, $text_line );
  44         }
  45     }
  46     @match_fails
  47       and push( @msg,
  48                     "required text "
  49                   . join( ", ", map { "'" . $_ . "'" } @match_fails )
  50                   . " not found in received content" );
  51
  52     @match_fails = ();
  53     foreach my $text_line ( @{$text_forbid} )
  54     {
  55         if ( $content =~ m/$case_ign\Q$text_line\E/ )
  56         {
  57             my $err_code = $self->get_check_value( $check, "text_forbid_code" ) // 1;
  58             $code = &{ $check->{compute_code} }( $code, $err_code );
  59             push( @match_fails, $text_line );
  60         }
  61     }
  62     @match_fails
  63       and push( @msg,
  64                     "forbidden text "
  65                   . join( ", ", map { "'" . $_ . "'" } @match_fails )
  66                   . " found in received content" );
  67
  68     if ( $code or @msg )
  69     {
  70         return ( $code, @msg );
  71     }
  72
  73     return (0);
  74 }
  75
  76 1;