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_003';
  13
  14 use 5.014;
  15
  16 sub check_value_names
  17 {
  18     return qw(regex_forbid regex_require);
  19 }
  20
  21 sub check_response
  22 {
  23     my ( $self, $check, $mech ) = @_;
  24
  25     my $regex_require = $self->get_check_value( $check, "regex_require" );
  26     my $regex_forbid  = $self->get_check_value( $check, "regex_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($regex_require)
  31       and ref($regex_require) ne "ARRAY"
  32       and $regex_require = [$regex_require];
  33     defined($regex_forbid) and ref($regex_forbid) ne "ARRAY" and $regex_forbid = [$regex_forbid];
  34
  35     my @match_fails;
  36     my $code = 0;
  37     my $case_ign = $ignore_case ? "(?i)" : "";
  38     my @msg;
  39     foreach my $regex_line ( @{$regex_require} )
  40     {
  41         if ( $content !~ m/$case_ign$regex_line/ )
  42         {
  43             my $err_code = $self->get_check_value( $check, "regex_require_code" ) // 1;
  44             $code = &{ $check->{compute_code} }( $code, $err_code );
  45             push( @match_fails, $regex_line );
  46         }
  47     }
  48     @match_fails
  49       and push( @msg,
  50                     "required regex "
  51                   . join( ", ", map { "'" . $_ . "'" } @match_fails )
  52                   . " not found in received content" );
  53
  54     @match_fails = ();
  55     foreach my $regex_line ( @{$regex_forbid} )
  56     {
  57         if ( $content =~ m/$case_ign$regex_line/ )
  58         {
  59             my $err_code = $self->get_check_value( $check, "regex_forbid_code" ) // 1;
  60             $code = &{ $check->{compute_code} }( $code, $err_code );
  61             push( @match_fails, $regex_line );
  62         }
  63     }
  64     @match_fails
  65       and push( @msg,
  66                     "forbidden regex "
  67                   . join( ", ", map { "'" . $_ . "'" } @match_fails )
  68                   . " found in received content" );
  69
  70     if ( $code or @msg )
  71     {
  72         return ( $code, @msg );
  73     }
  74
  75     return (0);
  76     return (0);
  77 }
  78
  79 1;
  80