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

   1 package WWW::Mechanize::Script::Plugin::RegexMatchTest;
   2
   3 use strict;
   4 use warnings;
   5
   6 use parent qw(WWW::Mechanize::Script::Plugin);
   7
   8 # ABSTRACT: check for required/forbidden text via regular expression in response
   9
  10 use Params::Util qw(_ARRAY0);
  11
  12 our $VERSION = '0.001_004';
  13
  14 use 5.014;
  15
  16 =method check_value_names()
  17
  18 Returns qw(regex_forbid regex_require).
  19
  20 =cut
  21
  22 sub check_value_names
  23 {
  24     return qw(regex_forbid regex_require);
  25 }
  26
  27 =method check_response(\%check,$mech)
  28
  29 This method checks whether any line of I<regex_forbid> matches against
  30 received content (and accumulates I<regex_forbid_code> into I<$code> when
  31 match) or any line of I<regex_require> doesn't match against content
  32 (and accumulates I<regex_forbid_code> into I<$code> unless match).
  33
  34 In case of an HTML response, the received content is rendered into plain
  35 text before searching for matches.
  36
  37 Return the accumulated I<$code> and appropriate constructed message, if
  38 any match approval failed.
  39
  40 =cut
  41
  42 sub check_response
  43 {
  44     my ( $self, $check, $mech ) = @_;
  45
  46     my $regex_require = $self->get_check_value( $check, "regex_require" );
  47     my $regex_forbid  = $self->get_check_value( $check, "regex_forbid" );
  48     my $ignore_case = $self->get_check_value_as_bool( $check, "ignore_case" );
  49     my $content = $mech->is_html() ? $mech->text() : $mech->content();
  50
  51     defined($regex_require)
  52       and ref($regex_require) ne "ARRAY"
  53       and $regex_require = [$regex_require];
  54     defined($regex_forbid) and ref($regex_forbid) ne "ARRAY" and $regex_forbid = [$regex_forbid];
  55
  56     my @match_fails;
  57     my $code = 0;
  58     my $case_ign = $ignore_case ? "(?i)" : "";
  59     my @msg;
  60     foreach my $regex_line ( @{$regex_require} )
  61     {
  62         if ( $content !~ m/$case_ign$regex_line/ )
  63         {
  64             my $err_code = $self->get_check_value( $check, "regex_require_code" ) // 1;
  65             $code = &{ $check->{compute_code} }( $code, $err_code );
  66             push( @match_fails, $regex_line );
  67         }
  68     }
  69     @match_fails
  70       and push( @msg,
  71                     "required regex "
  72                   . join( ", ", map { "'" . $_ . "'" } @match_fails )
  73                   . " not found in received content" );
  74
  75     @match_fails = ();
  76     foreach my $regex_line ( @{$regex_forbid} )
  77     {
  78         if ( $content =~ m/$case_ign$regex_line/ )
  79         {
  80             my $err_code = $self->get_check_value( $check, "regex_forbid_code" ) // 1;
  81             $code = &{ $check->{compute_code} }( $code, $err_code );
  82             push( @match_fails, $regex_line );
  83         }
  84     }
  85     @match_fails
  86       and push( @msg,
  87                     "forbidden regex "
  88                   . join( ", ", map { "'" . $_ . "'" } @match_fails )
  89                   . " found in received content" );
  90
  91     if ( $code or @msg )
  92     {
  93         return ( $code, @msg );
  94     }
  95
  96     return (0);
  97     return (0);
  98 }
  99
 100 1;
 101