File Coverage

blib/lib/HTML/FormFu/Constraint/Regex.pm
Criterion Covered Total %
statement 28 28 100.0
branch 13 14 92.8
condition 3 3 100.0
subroutine 5 5 100.0
pod 0 1 0.0
total 49 51 96.0


line stmt bran cond sub pod time code
1             package HTML::FormFu::Constraint::Regex;
2              
3 31     31   9988 use strict;
  31         48  
  31         1320  
4             our $VERSION = '2.05'; # VERSION
5              
6 31     31   113 use Moose;
  31         44  
  31         201  
7 31     31   132047 use MooseX::Attribute::FormFuChained;
  31         50  
  31         913  
8             extends 'HTML::FormFu::Constraint';
9              
10 31     31   14668 use Regexp::Common;
  31         59917  
  31         141  
11              
12             has common => ( is => 'rw', traits => ['FormFuChained'] );
13             has regex => ( is => 'rw', traits => ['FormFuChained'] );
14             has anchored => ( is => 'rw', traits => ['FormFuChained'] );
15              
16             sub constrain_value {
17 106     106 0 150 my ( $self, $value ) = @_;
18              
19 106 100 100     643 return 1 if !defined $value || $value eq '';
20              
21 87         92 my $regex;
22              
23 87 100       934 if ( defined $self->regex ) {
    100          
24 68         369 $regex = $self->regex;
25             }
26             elsif ( defined $self->common ) {
27             my @common
28             = ref $self->common
29 7 50       157 ? @{ $self->common }
  7         153  
30             : $self->common;
31              
32 7         10 $regex = shift @common;
33 7         33 $regex = $RE{$regex};
34              
35 7         164 for (@common) {
36 14 100       117 $regex = $regex->{ ref $_ ? join( $;, %$_ ) : $_ };
37             }
38             }
39             else {
40 12         38 $regex = qr/.*/;
41             }
42              
43 87 100       2740 if ( $self->anchored ) {
44 2         34 $regex = qr{^$regex\z};
45             }
46              
47 87         1736 my $ok = $value =~ $regex;
48              
49 87 100       3135 return $self->not ? !$ok : $ok;
50             }
51              
52             __PACKAGE__->meta->make_immutable;
53              
54             1;
55              
56             __END__
57              
58             =head1 NAME
59              
60             HTML::FormFu::Constraint::Regex - Regex Constraint
61              
62             =head1 VERSION
63              
64             version 2.05
65              
66             =head1 DESCRIPTION
67              
68             Regular expression-based constraint.
69              
70             =head1 METHODS
71              
72             =head2 regex
73              
74             Arguments: $regex. In a config file, enclose the regex in a string, like this: C<regex: '^[-_+=!\w\d]*\z'>.
75              
76             Arguments: $string
77              
78             =head2 common
79              
80             Arguments: \@parts
81              
82             Used to build a L<Regexp::Common> regex.
83              
84             The following definition is equivalent to
85             C<< $RE{URI}{HTTP}{-scheme => 'https?'} >>
86              
87             type: Regex
88             common:
89             - URI
90             - HTTP
91             - { '-scheme': 'https?' }
92              
93             =-head2 anchored
94              
95             Arguments: bool
96              
97             If true, uses C<^> and C<\z> to anchor the L</regex> or L</common>
98             to the start and end of the submitted value.
99              
100             =head1 SEE ALSO
101              
102             Is a sub-class of, and inherits methods from L<HTML::FormFu::Constraint>
103              
104             L<HTML::FormFu>
105              
106             =head1 AUTHOR
107              
108             Carl Franks C<cfranks@cpan.org>
109              
110             Based on the original source code of L<HTML::Widget::Constraint::Regex>, by
111             Sebastian Riedel, C<sri@oook.de>.
112              
113             =head1 LICENSE
114              
115             This library is free software, you can redistribute it and/or modify it under
116             the same terms as Perl itself.
117              
118             =cut