File Coverage

blib/lib/Brick/Regexes.pm
Criterion Covered Total %
statement 20 22 90.9
branch 1 4 25.0
condition 2 5 40.0
subroutine 6 7 85.7
pod n/a
total 29 38 76.3


line stmt bran cond sub pod time code
1             package Brick::Regexes;
2 5     5   28 use strict;
  5         9  
  5         188  
3              
4 5     5   19 use base qw(Exporter);
  5         6  
  5         446  
5 5     5   25 use vars qw($VERSION);
  5         8  
  5         277  
6              
7             $VERSION = '0.905';
8              
9             package Brick::Bucket;
10 5     5   22 use strict;
  5         6  
  5         83  
11              
12 5     5   25 use Carp qw(croak);
  5         8  
  5         1674  
13              
14             =encoding utf8
15              
16             =head1 NAME
17              
18             Brick - This is the description
19              
20             =head1 SYNOPSIS
21              
22             use Brick::Constraints;
23              
24             =head1 DESCRIPTION
25              
26             See C for the general discussion of constraint
27             creation.
28              
29             =head2 Utilities
30              
31             =over 4
32              
33             =item _matches_regex( HASHREF )
34              
35             Create a code ref to apply a regular expression to the named field.
36              
37             field - the field to apply the regular expression to
38             regex - a reference to a regular expression object ( qr// )
39              
40             =cut
41              
42             sub _matches_regex {
43 2     2   4 my( $bucket, $setup ) = @_;
44              
45 2         3 my @caller = $bucket->__caller_chain_as_list();
46              
47 2 50       4 unless( eval { $setup->{regex}->isa( ref qr// ) } ) {
  2         28  
48 0         0 croak( "Argument to $caller[0]{'sub'} must be a regular expression object" );
49             }
50              
51             $bucket->add_to_bucket ( {
52             name => $setup->{name} || $caller[0]{'sub'},
53             description => ( $setup->{description} || "Match a regular expression" ),
54             fields => [ $setup->{field} ],
55             code => sub {
56             die {
57             message => "[$_[0]->{ $setup->{field} }] did not match the pattern",
58             failed_field => $setup->{field},
59             failed_value => $_[0]->{ $setup->{field} },
60             handler => $caller[0]{'sub'},
61 0 0   0     } unless $_[0]->{ $setup->{field} } =~ m/$setup->{regex}/;
62             },
63 2   33     28 } );
      50        
64              
65             }
66              
67             =back
68              
69             =head1 TO DO
70              
71             Regex::Common support
72              
73             =head1 SEE ALSO
74              
75             TBA
76              
77             =head1 SOURCE AVAILABILITY
78              
79             This source is in Github:
80              
81             https://github.com/briandfoy/brick
82              
83             =head1 AUTHOR
84              
85             brian d foy, C<< >>
86              
87             =head1 COPYRIGHT
88              
89             Copyright © 2007-2026, brian d foy . All rights reserved.
90              
91             You may redistribute this under the terms of the Artistic License 2.0.
92              
93             =cut
94              
95             1;