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 29     29   11508 use strict;
  29         70  
  29         1805  
2              
3             package HTML::FormFu::Constraint::Regex;
4             $HTML::FormFu::Constraint::Regex::VERSION = '2.07';
5             # ABSTRACT: Regex Constraint
6              
7 29     29   182 use Moose;
  29         68  
  29         196  
8 29     29   210491 use MooseX::Attribute::Chained;
  29         77  
  29         1218  
9             extends 'HTML::FormFu::Constraint';
10              
11 29     29   16937 use Regexp::Common;
  29         78677  
  29         136  
12              
13             has common => ( is => 'rw', traits => ['Chained'] );
14             has regex => ( is => 'rw', traits => ['Chained'] );
15             has anchored => ( is => 'rw', traits => ['Chained'] );
16              
17             sub constrain_value {
18 97     97 0 306 my ( $self, $value ) = @_;
19              
20 97 100 100     544 return 1 if !defined $value || $value eq '';
21              
22 84         170 my $regex;
23              
24 84 100       1154 if ( defined $self->regex ) {
    100          
25 65         745 $regex = $self->regex;
26             }
27             elsif ( defined $self->common ) {
28             my @common
29             = ref $self->common
30 7 50       175 ? @{ $self->common }
  7         176  
31             : $self->common;
32              
33 7         14 $regex = shift @common;
34 7         42 $regex = $RE{$regex};
35              
36 7         211 for (@common) {
37 14 100       168 $regex = $regex->{ ref $_ ? join( $;, %$_ ) : $_ };
38             }
39             }
40             else {
41 12         46 $regex = qr/.*/;
42             }
43              
44 84 100       2818 if ( $self->anchored ) {
45 2         46 $regex = qr{^$regex\z};
46             }
47              
48 84         2141 my $ok = $value =~ $regex;
49              
50 84 100       3552 return $self->not ? !$ok : $ok;
51             }
52              
53             __PACKAGE__->meta->make_immutable;
54              
55             1;
56              
57             __END__
58              
59             =pod
60              
61             =encoding UTF-8
62              
63             =head1 NAME
64              
65             HTML::FormFu::Constraint::Regex - Regex Constraint
66              
67             =head1 VERSION
68              
69             version 2.07
70              
71             =head1 DESCRIPTION
72              
73             Regular expression-based constraint.
74              
75             =head1 METHODS
76              
77             =head2 regex
78              
79             Arguments: $regex. In a config file, enclose the regex in a string, like this: C<regex: '^[-_+=!\w\d]*\z'>.
80              
81             Arguments: $string
82              
83             =head2 common
84              
85             Arguments: \@parts
86              
87             Used to build a L<Regexp::Common> regex.
88              
89             The following definition is equivalent to
90             C<< $RE{URI}{HTTP}{-scheme => 'https?'} >>
91              
92             type: Regex
93             common:
94             - URI
95             - HTTP
96             - { '-scheme': 'https?' }
97              
98             =-head2 anchored
99              
100             Arguments: bool
101              
102             If true, uses C<^> and C<\z> to anchor the L</regex> or L</common>
103             to the start and end of the submitted value.
104              
105             =head1 SEE ALSO
106              
107             Is a sub-class of, and inherits methods from L<HTML::FormFu::Constraint>
108              
109             L<HTML::FormFu>
110              
111             =head1 AUTHOR
112              
113             Carl Franks C<cfranks@cpan.org>
114              
115             Based on the original source code of L<HTML::Widget::Constraint::Regex>, by
116             Sebastian Riedel, C<sri@oook.de>.
117              
118             =head1 LICENSE
119              
120             This library is free software, you can redistribute it and/or modify it under
121             the same terms as Perl itself.
122              
123             =head1 AUTHOR
124              
125             Carl Franks <cpan@fireartist.com>
126              
127             =head1 COPYRIGHT AND LICENSE
128              
129             This software is copyright (c) 2018 by Carl Franks.
130              
131             This is free software; you can redistribute it and/or modify it under
132             the same terms as the Perl 5 programming language system itself.
133              
134             =cut