# $Id: Filters.pm 2238 2007-03-24 06:04:33Z comdog $
package Brick::Filters;
use base qw(Exporter);
use vars qw($VERSION);
$VERSION = sprintf "1.%04d", q$Revision: 2238 $ =~ m/ (\d+) /xg;
package Brick::Bucket;
use strict;
=head1 NAME
Brick::Filters - do something to the input data
=head1 SYNOPSIS
use Brick;
=head1 DESCRIPTION
=over 4
=item _uppercase( HASHREF )
This modifies the input data permanently. It removes the non-digits
from the specified value in filter_fields. The value is no longer tainted
after this runs. It works on all of the fields.
filter_fields
This filter always succeeds, so it will not generate an validation
error.
=cut
sub _uppercase
{
my( $bucket, $setup ) = @_;
my @caller = $bucket->__caller_chain_as_list();
$bucket->add_to_bucket( {
name => $setup->{name} || $caller[0]{'sub'},
description => "filter: uppercase the input",
code => sub {
foreach my $f ( @{ $setup->{filter_fields} } )
{
next unless exists $_[0]->{ $f };
$_[0]->{ $f } = uc $_[0]->{ $f };
}
return 1;
},
} );
}
=item _lowercase( HASHREF )
This modifies the input data permanently. It removes the non-digits
from the specified value in filter_fields. The value is no longer tainted
after this runs. It works on all of the fields.
filter_fields
This filter always succeeds, so it will not generate an validation
error.
=cut
sub _lowercase
{
my( $bucket, $setup ) = @_;
my @caller = $bucket->__caller_chain_as_list();
$bucket->add_to_bucket( {
name => $setup->{name} || $caller[0]{'sub'},
description => "filter: uppercase the input",
code => sub {
foreach my $f ( @{ $setup->{filter_fields} } )
{
next unless exists $_[0]->{ $f };
$_[0]->{ $f } = lc $_[0]->{ $f };
}
return 1;
},
} );
}
=item _remove_non_digits( HASHREF )
This modifies the input data permanently. It removes the non-digits
from the specified value in filter_fields. The value is no longer tainted
after this runs. It works on all of the fields.
filter_fields
This filter always succeeds, so it will not generate an validation
error.
=cut
sub _remove_non_digits
{
my( $bucket, $setup ) = @_;
my @caller = $bucket->__caller_chain_as_list();
$bucket->add_to_bucket( {
name => $setup->{name} || $caller[0]{'sub'},
description => "filter: remove non-digits",
code => sub {
foreach my $f ( @{ $setup->{filter_fields} } )
{
next unless exists $_[0]->{ $f };
$_[0]->{ $f } =~ tr/0-9//cd;
$_[0]->{ $f } =
$_[0]->{ $f } =~ m/([0-9]*)/
?
$1
:
'';
}
return 1;
},
} );
}
=item _remove_whitespace( HASHREF )
This modifies the input data permanently. It removes the whitespace
from the specified value in filter_fields. The value is still tainted
after this runs.
filter_fields
This filter always succeeds, so it will not generate an error.
=cut
sub _remove_whitespace
{
my( $bucket, $setup ) = @_;
my @caller = $bucket->__caller_chain_as_list();
$bucket->add_to_bucket( {
name => $setup->{name} || $caller[0]{'sub'},
description => "filter: remove whitespace",
code => sub {
foreach my $f ( @{ $setup->{filter_fields} } )
{
next unless exists $_[0]->{ $f };
$_[0]->{ $f } =~ tr/\n\r\t\f //d;
}
},
} );
}
=item _remove_extra_fields( HASHREF )
This modifies the input data permanently. It removes any fields in
the input that are not also in the 'filter_fields' value in HASHREF.
filter_fields
This filter always succeeds, so it will not generate an error.
=cut
sub _remove_extra_fields
{
my( $bucket, $setup ) = @_;
my @caller = $bucket->__caller_chain_as_list();
my %allowed = map { $_, 1 } @{ $setup->{filter_fields} };
$bucket->add_to_bucket( {
name => $setup->{name} || $caller[0]{'sub'},
description => "filter: remove extra fields",
code => sub {
foreach my $f ( keys % {$_[0] } )
{
delete $_[0]->{$f} unless exists $allowed{$f};
}
},
} );
}
=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;