# $Id: Constraints.pm 2264 2007-05-09 17:06:24Z comdog $
package Brick::Constraints;
use base qw(Exporter);
use vars qw($VERSION);
$VERSION = sprintf "1.%04d", q$Revision: 2264 $ =~ m/ (\d+) /xg;
package Brick::Bucket;
use strict;
use subs qw();
use Carp qw(croak carp);
=head1 NAME
Brick::Constraints - Connect the input data to the closures in the pool
=head1 SYNOPSIS
use Brick;
=head1 DESCRIPTION
=over 4
=item __make_constraint( CODEREF, INPUT_HASH_REF )
Turn a closure into a constraint by providing the bridge between the
input hash and code reference.
Call this in your top level generator after you have composed all the
pieces you want.
=cut
sub __make_constraint # may need to change name to make generic
{
my( $bucket, $validator, $setup ) = @_;
$setup ||= {};
my @callers = $bucket->__caller_chain_as_list();
#print STDERR Data::Dumper->Dump( [\@callers], [qw(callers)] ); use Data::Dumper;
if( $#callers >= 1 and exists $callers[1]{'sub'} and $callers[1]{'sub'} =~ m/^_/ )
{
carp "$callers[1]{'sub'} called from sub with leading underscore. Are you sure you want that?";
}
my $name = $setup->{name} || $callers[1]{'sub'} || 'Anonymous';
print STDERR "Constraint name is $name\n" if $ENV{DEBUG};
unless(
eval { $validator->isa( ref sub {} ) } ||
UNIVERSAL::isa( $validator, ref sub {} )
)
{
croak( "Argument to $callers[1]{'sub'} must be a code reference [$validator]: $@" );
}
my $constraint = $bucket->add_to_bucket( {
name => $name,
description => "Brick constraint sub for $name",
code => sub {
my $input_hash = shift;
my $result = eval{ $validator->( $input_hash ) };
die if $@;
return 1;
},
} );
$bucket->comprise( $constraint, $validator );
return $constraint;
}
=item __make_dfv_constraint
Adapter for Data::FormValidator
=cut
=pod
sub __make_dfv_constraint # may need to change name to make generic
{
my( $bucket, $validator, $hash ) = @_;
$hash ||= {};
my @callers = main::__caller_chain_as_list();
my $name = $hash->{profile_name} || $callers[-1]{'sub'} || 'Anonymous';
unless(
eval { $validator->isa( ref sub {} ) } or
UNIVERSAL::isa( $validator, ref sub {} )
)
{
carp( "Argument to $callers[1]{'sub'} must be a code reference [$validator]: $@" );
return $bucket->add_to_bucket( { code => sub {}, name => "Null subroutine",
description => "This sub does nothing, because something didn't happen correctly."
} );
}
my $constraint = $bucket->add_to_bucket( {
name => $name,
description => "Data::FormValidator constraint sub for $callers[-1]{'sub'}",
code => sub {
my( $dfv ) = @_;
$dfv->name_this( $callers[-1]{'sub'} );
my( $field, $value ) = map {
$dfv->${\ "get_current_constraint_$_"}
} qw(field value);
my $hash_ref = $dfv->get_filtered_data;
return unless $validator->( $hash_ref );
return $field;
},
} );
$bucket->comprise( $constraint, $validator );
return $constraint;
}
=back
=head1 TO DO
TBA
=head1 SEE ALSO
TBA
=head1 SOURCE AVAILABILITY
This source is part of a SourceForge project which always has the
latest sources in SVN, as well as all of the previous releases.
svn co https://brian-d-foy.svn.sourceforge.net/svnroot/brian-d-foy brian-d-foy
If, for some reason, I disappear from the world, one of the other
members of the project can shepherd this module appropriately.
=head1 AUTHOR
brian d foy, C<< <bdfoy@cpan.org> >>
=head1 COPYRIGHT
Copyright (c) 2007, brian d foy, All Rights Reserved.
You may redistribute this under the same terms as Perl itself.
=cut
1;