From: Jens Rehsack <sno@NetBSD.org>
Date: Tue, 7 Aug 2012 14:44:23 +0000 (+0200)
Subject: introducing regex check analogous to text match check
X-Git-Tag: v0.100~13
X-Git-Url: https://repo.or.cz/w/WWW-Mechanize-Script.git/commitdiff_plain/de75605018093ee4bdc76e1c954a784d243cec7d

introducing regex check analogous to text match check
---

diff --git a/lib/WWW/Mechanize/Script/Plugin/RegexMatchTest.pm b/lib/WWW/Mechanize/Script/Plugin/RegexMatchTest.pm
new file mode 100644
index 0000000..98b25d1
--- /dev/null
+++ b/lib/WWW/Mechanize/Script/Plugin/RegexMatchTest.pm
@@ -0,0 +1,76 @@
+package WWW::Mechanize::Script::Plugin::RegexMatchTest;
+
+use strict;
+use warnings;
+
+use parent qw(WWW::Mechanize::Script::Plugin);
+
+use Params::Util qw(_ARRAY0);
+
+our $VERSION = '0.001_002';
+
+use 5.014;
+
+sub check_value_names
+{
+    return qw(regex_forbid regex_require);
+}
+
+sub check_response
+{
+    my ( $self, $check, $mech ) = @_;
+
+    my $regex_require = $self->get_check_value( $check, "regex_require" );
+    my $regex_forbid  = $self->get_check_value( $check, "regex_forbid" );
+    my $ignore_case = $self->get_check_value_as_bool( $check, "ignore_case" );
+    my $content = $mech->is_html() ? $mech->text() : $mech->content();
+
+    defined($regex_require) and ref($regex_require) ne "ARRAY" and $regex_require = [$regex_require];
+    defined($regex_forbid) and ref($regex_forbid) ne "ARRAY" and $regex_forbid = [$regex_forbid];
+
+    my @match_fails;
+    my $code = 0;
+    my $case_ign = $ignore_case ? "(?i)" : "";
+    my @msg;
+    foreach my $regex_line ( @{$regex_require} )
+    {
+        if ( $content !~ m/$case_ign$regex_line/ )
+        {
+            my $err_code = $self->get_check_value( $check, "regex_require_code" ) // 1;
+            $code = &{ $check->{compute_code} }( $code, $err_code );
+            push( @match_fails, $regex_line );
+        }
+    }
+    @match_fails
+      and push( @msg,
+                    "required regex "
+                  . join( ", ", map { "'" . $_ . "'" } @match_fails )
+                  . " not found in received content" );
+
+    @match_fails = ();
+    foreach my $regex_line ( @{$regex_forbid} )
+    {
+        if ( $content =~ m/$case_ign$regex_line/ )
+        {
+            my $err_code = $self->get_check_value( $check, "regex_forbid_code" ) // 1;
+            $code = &{ $check->{compute_code} }( $code, $err_code );
+            push( @match_fails, $regex_line );
+        }
+    }
+    @match_fails
+      and push( @msg,
+                    "forbidden regex "
+                  . join( ", ", map { "'" . $_ . "'" } @match_fails )
+                  . " found in received content" );
+
+    if ( $code or @msg )
+    {
+        return ( $code, @msg );
+    }
+
+    return (0);
+    return (0);
+}
+
+1;
+