File Coverage

blib/lib/Brick/Constraints.pm
Criterion Covered Total %
statement 26 33 78.7
branch 3 8 37.5
condition 5 13 38.4
subroutine 6 9 66.6
pod n/a
total 40 63 63.4


line stmt bran cond sub pod time code
1             package Brick::Constraints;
2 5     5   33 use base qw(Exporter);
  5         13  
  5         604  
3 5     5   36 use vars qw($VERSION);
  5         8  
  5         271  
4              
5             $VERSION = '0.901';
6              
7             package Brick::Bucket;
8 5     5   29 use strict;
  5         12  
  5         138  
9              
10 5     5   25 use subs qw();
  5         9  
  5         144  
11              
12 5     5   28 use Carp qw(croak carp);
  5         9  
  5         2063  
13              
14             =encoding utf8
15              
16             =head1 NAME
17              
18             Brick::Constraints - Connect the input data to the closures in the pool
19              
20             =head1 SYNOPSIS
21              
22             use Brick;
23              
24             =head1 DESCRIPTION
25              
26             =over 4
27              
28             =item __make_constraint( CODEREF, INPUT_HASH_REF )
29              
30             Turn a closure into a constraint by providing the bridge between the
31             input hash and code reference.
32              
33             Call this in your top level generator after you have composed all the
34             pieces you want.
35              
36             =cut
37              
38             sub __make_constraint # may need to change name to make generic
39             {
40 2     2   5 my( $bucket, $validator, $setup ) = @_;
41              
42 2   50     5 $setup ||= {};
43              
44 2         6 my @callers = $bucket->__caller_chain_as_list();
45              
46             #print STDERR Data::Dumper->Dump( [\@callers], [qw(callers)] ); use Data::Dumper;
47              
48 2 50 33     16 if( $#callers >= 1 and exists $callers[1]{'sub'} and $callers[1]{'sub'} =~ m/^_/ )
      33        
49             {
50 0         0 carp "$callers[1]{'sub'} called from sub with leading underscore. Are you sure you want that?";
51             }
52              
53 2   50     11 my $name = $setup->{name} || $callers[1]{'sub'} || 'Anonymous';
54 2 50       6 print STDERR "Constraint name is $name\n" if $ENV{DEBUG};
55              
56 2 50 33     3 unless(
57 2     0   45 eval { $validator->isa( ref sub {} ) } ||
58       0     UNIVERSAL::isa( $validator, ref sub {} )
59             )
60             {
61 0         0 croak( "Argument to $callers[1]{'sub'} must be a code reference [$validator]: $@" );
62             }
63              
64             my $constraint = $bucket->add_to_bucket( {
65             name => $name,
66             description => "Brick constraint sub for $name",
67              
68             code => sub {
69 0     0   0 my $input_hash = shift;
70              
71 0         0 my $result = eval{ $validator->( $input_hash ) };
  0         0  
72 0 0       0 die if $@;
73              
74 0         0 return 1;
75             },
76 2         21 } );
77              
78 2         8 $bucket->comprise( $constraint, $validator );
79              
80 2         13 return $constraint;
81             }
82              
83              
84             =item __make_dfv_constraint
85              
86             Adapter for Data::FormValidator
87              
88             =cut
89              
90             =pod
91              
92             sub __make_dfv_constraint # may need to change name to make generic
93             {
94             my( $bucket, $validator, $hash ) = @_;
95              
96             $hash ||= {};
97              
98             my @callers = main::__caller_chain_as_list();
99              
100             my $name = $hash->{profile_name} || $callers[-1]{'sub'} || 'Anonymous';
101              
102             unless(
103             eval { $validator->isa( ref sub {} ) } or
104             UNIVERSAL::isa( $validator, ref sub {} )
105             )
106             {
107             carp( "Argument to $callers[1]{'sub'} must be a code reference [$validator]: $@" );
108             return $bucket->add_to_bucket( { code => sub {}, name => "Null subroutine",
109             description => "This sub does nothing, because something didn't happen correctly."
110             } );
111             }
112              
113             my $constraint = $bucket->add_to_bucket( {
114             name => $name,
115             description => "Data::FormValidator constraint sub for $callers[-1]{'sub'}",
116              
117             code => sub {
118             my( $dfv ) = @_;
119              
120             $dfv->name_this( $callers[-1]{'sub'} );
121             my( $field, $value ) = map {
122             $dfv->${\ "get_current_constraint_$_"}
123             } qw(field value);
124              
125             my $hash_ref = $dfv->get_filtered_data;
126              
127             return unless $validator->( $hash_ref );
128              
129             return $field;
130             },
131             } );
132              
133             $bucket->comprise( $constraint, $validator );
134              
135             return $constraint;
136             }
137              
138             =back
139              
140             =head1 TO DO
141              
142             TBA
143              
144             =head1 SEE ALSO
145              
146             TBA
147              
148             =head1 SOURCE AVAILABILITY
149              
150             This source is in Github:
151              
152             https://github.com/briandfoy/brick
153              
154             =head1 AUTHOR
155              
156             brian d foy, C<< >>
157              
158             =head1 COPYRIGHT
159              
160             Copyright © 2007-2021, brian d foy . All rights reserved.
161              
162             You may redistribute this under the terms of the Artistic License 2.0.
163              
164             =cut
165              
166             1;