package CGI::FormBuilderX::More;
use warnings;
use strict;
=head1 NAME
CGI::FormBuilderX::More - Additional input gathering/interrogating functionality for CGI::FormBuilder
=head1 VERSION
Version 0.020
=cut
our $VERSION = '0.020';
=head1 SYNOPSIS
use CGI::FormBuilderX::More;
my $form = CGI::FormBuilderX::More( ... );
if ($form->pressed("edit")) {
my $input = $form->input_slice(qw/title description/);
# $input is { title => ..., description => ... } *ONLY*
...
}
elsif ($form->pressed("view") && ! $form->missing("section")) {
# The paramter "section" is defined and is not ''
...
}
print $form->render;
...
# Using the alternative, subroutine-driven, validation
my $form = CGI::FormBuilderX::More( ..., validate => sub {
my ($form, $error) = @_;
if (! exists $_{username}) {
$error->("username is required"); # Register the error
}
elsif ($_{username} =~ m/\W/) {
$error->("username is malformed"); # A username was given but it's bad
}
if (! exists $_{password}) {
$error->("password is required"); # Another error...
}
return if $error->(); # See if we've accumulated any errors
unless (&authenticate({ $form->input_slice(qw/username password/) })) {
$error->("no such username or incorrect password");
}
});
if ($form->validate) {
}
else {
}
=head1 DESCRIPTION
CGI::FormBuilderX::More extends CGI::FormBuilder by adding some convenience methods. Specifically,
it adds methods for generating param lists, generating param hash slices, determining whether a param is "missing",
and finding out which submit button was pressed.
=head1 EXPORT
=head2 missing( <value> )
Returns 1 if <value> is not defined or the empty string ('')
Returns 0 otherwise
Note, the number 0 is NOT a "missing" value
=cut
use base qw/CGI::FormBuilder/;
use CGI::FormBuilderX::More::InputTie;
use Sub::Exporter -setup => {
exports => [
missing => sub { return sub {
return ! defined $_[0] || $_[0] eq '';
} },
],
};
sub _attribute($) {
return "_CGI_FBX_M_$_[0]";
}
=head1 METHODS
=head2 CGI::FormBuilderX::More->new( ... )
Returns a new CGI::FormBuilderX::More object
Configure exactly as you would a normal CGI::FormBuilder object
=cut
sub new {
my $class = shift;
my $hash;
if (@_ == 1 && ref $_[0] eq "HASH") {
$hash = $_[0];
}
elsif (@_ > 1) {
$hash = { @_ };
}
my $self;
if ($hash) {
my $validate;
if ($hash->{validate} && ref $hash->{validate} eq "CODE") {
$validate = delete $hash->{validate};
}
$self = $class->SUPER::new($hash);
$self->{_attribute("validate")} = $validate;
}
else {
$self = $class->SUPER::new(@_);
}
return $self;
}
=head2 pressed( <name> )
Returns the value of ->param(_submit_<name>) if _submit_<name> exists and has a value
If not, then returns the value of ->param("_submit_<name>.x") if "_submit_<name>.x" exists and has a value
If <name> is not given, then it will use the form's default submit name to check.
To suppress the automatic prefixing of <name> with "_submit", simply prefix a "+" to <name>
If <name> already has a "_submit" prefix, then none will be applied.
Otherwise, returns undef
Essentially, you can use this method to find out which button the user pressed. This method does not require
any javascript on the client side to work
It checks "_submit_<name>.x" because for image buttons, some browsers only submit the .x and .y values of where the user
pressed.
=cut
sub pressed {
my $self = shift;
my ($name, $default);
if (! @_) {
$name = $self->submitname;
$default = 1;
}
else {
$name = shift;
if (defined $name && length $name) {
$name = "_submit_$name" unless $name =~ m/^_submit/i || $name =~ s/^\+//;
}
else {
$name = $self->submitname;
}
}
for ($name, "$name.x") {
if (defined (my $value = $self->input_fetch($_))) {
return $value || '0E0';
}
}
return $self->submitted if $default;
return undef;
}
=head2 missing( <name> )
Returns 1 if value of the param <name> is not defined or the empty string ('')
Returns 0 otherwise
Note, the number 0 is NOT a "missing" value
value missing
===== =======
"xyzzy" no
0 no
1 no
"" yes
undef yes
=cut
sub missing {
my $self = shift;
my $name = shift;
my $value = $self->input_fetch($name);
return 0 if $value;
return 1 if ! defined $value;
return 1 if $value eq '';
return 0; # value is 0
}
=head2 input ( <name>, <name>, ..., <name> )
Returns a list of values based on the param names given
By default, this method will "collapse" multi-value params into the first
value of the param. If you'd prefer an array reference of multi-value params
instead, pass the option { all => 1 } as the first argument (a hash reference).
=cut
sub input {
my $self = shift;
return $self->input_fetch(@_) if wantarray && 1 == @_ && ! ref $_[0];
my $control = {};
$control = shift if ref $_[0] && ref $_[0] eq "HASH";
my $all = 0;
$all = $control->{all} if exists $control->{all};
my @names = map { ref eq 'ARRAY' ? @$_ : $_ } @_;
my @params;
if ($all) {
for (@names) {
my @param = $self->input_fetch($_);
push @params, 1 == @param ? $param[0] : \@param;
}
}
else {
for (@names) {
push @params, scalar $self->input_fetch($_);
}
}
return wantarray ? @params : $params[0];
}
=head2 input_slice( <name>, <name>, ..., <name> )
Returns a hash of key/value pairs based on the param names given
By default, this method will "collapse" multi-value params into the first
value of the param. If you'd prefer an array reference of multi-value params
instead, pass the option { all => 1 } as the first argument (a hash reference).
=cut
sub input_slice {
my $self = shift;
my $control = {};
$control = shift if ref $_[0] && ref $_[0] eq "HASH";
my $all = 0;
$all = $control->{all} if exists $control->{all};
my @names = map { ref eq 'ARRAY' ? @$_ : $_ } @_;
my %slice;
if ($all) {
%slice = map { my @param = $self->input_fetch($_); ($_ => 1 == @param ? $param[0] : \@param) } @names;
}
else {
%slice = map { ($_ => scalar $self->input_fetch($_)) } @names;
}
return wantarray ? %slice : \%slice;
}
=head2 input_slice_to( <hash>, <name>, <name>, ..., <name> )
The behavior of this method is similar to C<input_slice>, except instead of returning a new hash, it will modify
the hash passed in as the first argument.
Returns the original hash passed in
=cut
sub input_slice_to {
my $self = shift;
my $hash = shift;
my $slice = { $self->input_slice(@_) };
$hash->{$_} = $slice->{$_} for keys %$slice;
return $hash;
}
=head2 input_param( <name> )
In list context, returns the all the param values associated with <name>
In scalar context, returns only the first param value associated with <name>
The main difference between C<input_param> and C<input> is that C<input_param> only accepts a single argument
AND C<input_param> addresses the param object directly, while C<input> will access the internal C<input_fetch>/C<input_store> hash
=cut
sub input_param {
my $self = shift;
my @param = $self->{params}->param($_[0]);
return wantarray ? @param : shift @param;
}
=head2 validate( [<code>] )
In CGI::FormBuilderX::More, we overload to the validate method to offer different behavior. This different
behavior is conditional, and depends on the optional first argument, or the value of C<validate> passed in to C<new>.
If either the first argument or ->new( validate => ... ) is a code reference then $form->validate takes on different behavior:
1. %_ is tied() to the form's input parameters
2. An error subroutine for recoding errors is passed through as the first argument to the validation subroutine
3. Any additional arguments to validate are passed through to the validation subroutine
4. The errors are available via $form->errors, which is a list reference
5. The errors are also available in the prepared version of $form (e.g. for template rendering)
6. $form->validate returns true or false depending on whether any errors were encountered
Here is an example validation subroutine:
sub {
my ($form, $error) = @_;
if (! exists $_{username}) {
$error->("username is required"); # Register the error
}
elsif ($_{username} =~ m/\W/) {
$error->("username is malformed"); # A username was given but it's bad
}
if (! exists $_{password}) {
$error->("password is required"); # Another error...
}
return if $error->(); # See if we've accumulated any errors
unless (&authenticate({ $form->input_slice(qw/username password/) })) {
$error->("no such username or incorrect password");
}
}
=cut
sub validate {
my $self = shift;
my $code;
if ($_[0] && ref $_[0] eq "CODE") {
$code = shift;
}
elsif ($code = $self->{_attribute("validate")}) {
}
else {
return $self->SUPER::validate(@_);
}
local %_;
$self->input_tie(\%_);
my @errors;
my $error = sub {
return @errors ? 1 : 0 unless @_;
push @errors, @_;
};
eval {
$code->($self, $error, @_);
};
{
my $error = $@;
untie %_;
die $error if $error;
}
$self->{_attribute("errors")} = \@errors;
return scalar @errors ? 0 : 1;
}
=head2 input_tie( <hash> )
Given a hash reference, C<input_tie> will tie the hash to form input. That is,
accessing a hash entry is actually accessing the corresponding form param.
Currently, only STORE, FETCH, and EXISTS are implemented.
my %hash;
$form->input_tie(\%hash);
my $value = $hash{username}; # Actually does: $form->input_fetch("username");
$hash{password} = "12345"; # Actually does: $form->input_store(password => "12345");
return unless exists $hash{extra}; # Actually does: ! $form->missing("extra");
# Which checks to see if "extra" is defined and a non-empty string.
=cut
sub input_tie {
my $self = shift;
my $hash = shift;
tie %$hash, "CGI::FormBuilderX::More::InputTie", $self;
return $hash;
}
=head2 input_fetch( <key> )
Given a key, C<input_fetch> will return the value of first
an internal attribute stash, and then request paramters (via C<input_param>).
This allows you get/set values in the form without affecting the underlying request param.
In array context, the entire value list is returned. In scalar context, only the first value is returned.
=cut
sub input_fetch {
my $self = shift;
my $key = shift;
if (exists $self->{_attribute("input")}->{$key}) {
my @param = @{ $self->{_attribute("input")}->{$key} };
return wantarray ? @param : shift @param;
}
else {
return $self->input_param($key);
}
}
=head2 input_store( <key>, <value>, <value>, ..., <value> )
Given a key and some values, C<input_store> will store the values (as an array reference)
in an internal attribute stash.
This allows you get/set values in the form without affecting the underlying request param.
=cut
sub input_store {
my $self = shift;
my $key = shift;
my @values = 1 == @_ && ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_;
$self->{_attribute("input")}->{$key} = \@values;
}
=head2 errors
In scalar context, returns an array reference of errors found during validation, if any.
In list context, returns the same, but as a list.
=cut
sub errors {
my $self = shift;
if (@_) {
my @errors = 1 == @_ && ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_;
$self->{_attribute("errors")} = \@errors;
}
my $errors = $self->{_attribute("errors")} || [];
return wantarray ? @$errors : [ @$errors ];
}
=head2 prepare
Prepares a hash containing information about the state of the form and returns it.
Essentially, returns the same as CGI::FormBuilder->prepare, with the addition of C<errors>, which is
a list of any errors found during validation.
Returns a hash reference in scalar context, and a key/value list in array context.
=cut
sub prepare {
my $self = shift;
my $prepare = $self->SUPER::prepare(@_);
$prepare->{errors} = $self->errors;
return wantarray ? %$prepare : $prepare;
}
=head1 AUTHOR
Robert Krimen, C<< <rkrimen at cpan.org> >>
=head1 BUGS
Please report any bugs or feature requests to C<bug-cgi-formbuilderx-more at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CGI-FormBuilderX-More>. I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc CGI::FormBuilderX::More
You can also look for information at:
=over 4
=item * RT: CPAN's request tracker
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=CGI-FormBuilderX-More>
=item * AnnoCPAN: Annotated CPAN documentation
L<http://annocpan.org/dist/CGI-FormBuilderX-More>
=item * CPAN Ratings
L<http://cpanratings.perl.org/d/CGI-FormBuilderX-More>
=item * Search CPAN
L<http://search.cpan.org/dist/CGI-FormBuilderX-More>
=back
=head1 ACKNOWLEDGEMENTS
=head1 COPYRIGHT & LICENSE
Copyright 2007 Robert Krimen, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
1; # End of CGI::FormBuilderX::More