Data::CGIForm - Form Data Interface.

 my %spec = (
     username => qr/^([a-z0-9]+)$/,
     password => {
         regexp => qr/^([a-z0-9+])$/,
         filter => [qw(strip_leading_ws, strip_trailing_ws)],
     },
     email => {
         regexp   => qr/^([a-z0-9@.]+)$/,
         filter   => \&qualify_domain,
         optional => 1,
         errors => {
             empty   => 'You didn\'t enter an email address.',
             invalid => 'Bad [% key %]: "[% value %]"',
         },
         extra_test   => \&check_email_addr,
     },
     email2 => {
     	equal_to => email,
     	errors   => {
     		unequal => 'Both email addresses must be the same.',
     	},
     },
 );

 my $r    = $ENV{'MOD_PERL'} ? Apache::Request->instance : CGI->new;

 my $form = Data::CGIForm->new(datasource => $r, spec => \%spec);




 my @params = $form->params;
 foreach $param (@params) {
     next unless my $error_string = $form->error($param);

     print STDERR $error_string;
 }

 if ($form->error('username')) {
     handle_error($form->username, $form->error('username'));
 }

 my $email    = $form->param('email');
 my $password = $form->password;

 %spec = (
     key => qr/.../,
 );

 sub fix_newlines {
     my $textref = shift;
	 $$textref   =~ s/[\n\r]*/\n/sg;
 }

 %spec = (
     field => {
         errors => {
             empty   => "You didn't fill this out!"
             invalid => "That doesn't look right!"
         },
         ...
     },
 ); 

 [% key %]     == Becomes ==> The current keyname.
 [% value %]   == Becomes ==> The value for the current key.

 errors => {
     invalid => "[% value %] doesn't look like a [% key %]",
 }

 sub is_right_size {
     return (${$_[0]} > 100 and ${$_[0]} < 1250);
 }

 sub check_email {
     my ($textref, $form, $key) = @_;
     unless (Email::Valid->address($$textref)) {
         $form->error(
             $key => "address failed $Email::Valid::Details check."
         );
         return;
     }
     return 1;
 }

 sub check_email {
     my ($textref, $form, $key) = @_;
     unless (Email::Valid->address($$textref)) {
         $form->param($key => '');
         $form->error(
             $key => "address failed $Email::Valid::Details check."
         );
         return;
     }
     return 1;
 }

  Data::CGIForm->new(datasource => $r, spec => \%spec, %options)

package Data::CGIForm;
#
# $Id: CGIForm.pm 2 2010-06-25 14:41:40Z twilde $
#
use 5.006;
use strict;
use warnings;
use Carp ();

our $VERSION = 0.5;

our %Filters = (
	strip_leading_ws  => sub { ${$_[0]} =~ s/^\s*//   },
	strip_trailing_ws => sub { ${$_[0]} =~ s/\s*$//   },
	strip_ws		  => sub { ${$_[0]} =~ s/\s*//g   },
	lc				  => sub { ${$_[0]} = lc ${$_[0]} },
	uc				  => sub { ${$_[0]} = uc ${$_[0]} },
);

our %DefaultErrors = (
	invalid => 'The input for [% key %] ("[% value %]") is invalid.',
	empty   => '"[% key %]" not given.',
	unequal => 'The two fields must match.',
	length  => 'The input for [% key %} ("[% value %]") does not meet length constraints.',
);

our @ValidErrorFields = qw(invalid empty unequal length);

sub new {
	my $class = shift;
	
	Carp::croak("${class}->new(): Odd number of parameters given.") unless @_ % 2 == 0;
	
	my %params = @_;
	
	for (qw(datasource spec)) {
		Carp::croak("${class}->new(): $_ not given.") unless $params{$_};
	}
	
	unless (ref $params{'datasource'} and $params{'datasource'}->can('param')) {
		Carp::croak("${class}->new(): 'datasource' must be an object with a param() method.");
	}
	
	unless (ref $params{'spec'} and ref $params{'spec'} eq 'HASH') {
		Carp::croak("${class}->new(): 'spec' must be a hashref.");
	}
	
	my $self = {
		spec   => {},
		data   => {},
		errors => {},
	};
	
	if ($params{'start_param'}) {
		unless ($params{'spec'}->{$params{'start_param'}}) {
			Carp::croak(qq(${class}->new(): 'start_param' ("$params{'start_param'}") not listed in the spec.));
		}
		
		$self->{'start_param'} = $params{'start_param'};
	}
		
	
	bless($self, $class);
	
	# Scan the user spec, and normalize it
	$self->_scan_spec($params{'spec'});
	
	# pull the data from the datasource
	$self->_populate_vars($params{'datasource'});
	
	# run the validation spec
	$self->_validate_params unless $self->{'in_unstarted_mode'};
	
	return $self;
}

#
# $form->_scan_spec($spec)
#
# Runs though the given spec, and normalizes it.
#
sub _scan_spec {
	 my ($self, $s) = @_;
	 	 
	 foreach my $param (keys %$s) {
	 	my $value = $s->{$param};
	 		 	
	 	Carp::croak("new(): spec error: $param is not a ref") unless ref $value;
		
		if (ref $value eq 'HASH') {
			$self->_insert_spec($param => $value);
		} elsif (ref $value eq 'Regexp') {
			$self->_insert_spec($param => { regexp => $value});
		} else {
			Carp::croak("new(): spec error: $param is not a hashref or regexp");
		}
	}	
	
	$self->_insert_delayed_specs if $self->{'delayed_specs'};
}

#
# $form->_insert_spec($key => $spec)
#
# Does most of the heavy lifting for _scan_spec
#
sub _insert_spec {
	my ($self, $key, $old_spec) = @_;
	
	#
	# Make a copy just to be safe.
	#
	my $s = { %$old_spec };

	if ($s->{'equal_to'}) {
		# equal_to rules must be inserted last, so 
		# they can see all the other data that has been inserted.
		$self->{'delayed_specs'}->{$key} = $s;
		return;
	}
	
		
	
	my $regexp   = delete $s->{'regexp'};
	
	Carp::croak("new(): spec error: no regexp given for '$key'.")
		unless $regexp;
	
	Carp::croak("new(): spec error: regexp for '$key' not a regexp.")
		unless ref $regexp and ref $regexp eq 'Regexp';
		
	my $optional   = delete $s->{'optional'} ? 1 : 0;
	my $errors     = delete $s->{'errors'};
	
	my $filter     = delete $s->{'filter'};
	my $extra_test = delete $s->{'extra_test'};
	
	my $length     = delete $s->{'length'};
	my $min_length = delete $s->{'min_length'};
	my $max_length = delete $s->{'max_length'};
	
	if (%{$s}) {
		Carp::croak("new(): spec error: invalid options for $key: @{[ keys %{$s} ]}");
	}
	
	my %spec = (
		optional     => $optional,
		regexp       => $regexp,		
	);
	
	$spec{'length'}     = $length     if $length;
	$spec{'min_length'} = $min_length if $min_length;
	$spec{'max_length'} = $max_length if $max_length;
	
	if ($filter) {
		my @filters = (ref $filter and ref $filter eq 'ARRAY') ? @{$filter} : ($filter);
		
		foreach my $f (@filters) {
			if ($Filters{$f}) {
				push(@{$spec{'filter'}}, $Filters{$f});
			} elsif (ref $f and ref $f eq 'CODE') {
				push(@{$spec{'filter'}}, $f);
			} else {
				Carp::croak("new(): spec error: No such built in filter: $f");
			}
		}
	}
	
	if ($extra_test) {
		my @tests = (ref $extra_test and ref $extra_test eq 'ARRAY') ? @{$extra_test} : ($extra_test);
		
		foreach my $t (@tests) {
			if (ref $t and ref $t eq 'CODE') {
				push(@{$spec{'extra_test'}}, $t);
			} else {
				Carp::croak('new(): spec error: extra tests must be a code reference.');
			}
		}
	}
	
	if ($errors) {
		#
		# Make a copy just to be safe. (we use delete here too)
		#
		$errors = { %$errors };
		
		unless (ref $errors and ref $errors eq 'HASH') {
			Carp::croak('new(): spec error: errors not a hashref');
		}
		
		my %errors = ();
			
		foreach my $type (@ValidErrorFields) {
			my $msg = delete $errors->{$type} || next;
			$errors{$type} = $msg;
		}
		
		if (%{$errors}) {
			Carp::croak("new(): spec error: invalid error message types: @{[ keys %{$errors} ]}");
		}
		
		$spec{'errors'} = \%errors;
	}	
	
	$self->{'spec'}->{$key} = \%spec;
}


sub _insert_delayed_specs {
	my ($self) = @_;

	while (my ($key, $s) = each %{$self->{'delayed_specs'}}) {
		my $equal_to = delete $s->{'equal_to'} || Carp::confess("How did we get a delayed spec with no equal_to?!");
	
		unless ($self->{'spec'}->{$equal_to}) {
			Carp::croak("new(): spec error: equal_to set to unknown parameter: $equal_to.");
		}
	
		$s->{'regexp'}     = qr/^(.*)$/;
		$s->{'extra_test'} = sub {
			my ($textref, $form) = @_;
 		
			return unless my $value = $form->param($equal_to);
			
			if ($$textref eq $value) {
				return 1;
			} else {
				$form->param( $equal_to  => '');
				$form->param( $key => '');
				
				$self->errorf($key      => unequal => $$textref);
				$self->error( $equal_to => $self->error($key));
				
				return 0;
			}
		};
		
		$self->_insert_spec($key, $s);
	}
}

#
# $form->_populate_vars($datasource)
#
# Goes though the spec, grabbing data from the datasource for each var.	
#	
sub _populate_vars {
	my ($self, $data) = @_;
	
	$self->{'in_unstarted_mode'} = 1 if $self->{'start_param'} 
									and !$data->param($self->{'start_param'});
	
	if ($self->{'in_unstarted_mode'}) {
		foreach my $key (keys %{$self->{'spec'}}) {
			$self->{'data'}->{$key} = [''];
		}
	} else {
		foreach my $key (keys %{$self->{'spec'}}) {
			@{$self->{'data'}->{$key}} = $data->param($key);
		}
	}
}


#
# $form->_validate_params
#
# Runs though the spec, validating the data we got from the datastore.
# If the data is bad, we drop it to the floor, and set an error message.
#
sub _validate_params {
	my ($self) = @_;
	
	KEY: while (my ($key, $spec) = each %{$self->{'spec'}}) {

		my @new_data;
		
		unless (@{$self->{'data'}->{$key}}) {
			$self->errorf($key => 'empty', $_) unless $self->error($key) || $spec->{'optional'};
			next KEY;
		}
		
		
		MEMBER: for (@{$self->{'data'}->{$key}}) {
			next MEMBER if defined $_ and length $_;
						
			$self->errorf($key => 'empty', $_) unless $self->error($key) || $spec->{'optional'};
			next KEY;
		}
		
		DATA: foreach my $data (@{$self->{'data'}->{$key}}) {
			
			next DATA unless defined $data;
				
			if ($spec->{'filter'}) {
				$_->(\$data) for @{$spec->{'filter'}};
			}  
			
			unless ($data =~ $spec->{'regexp'}) {
				$self->errorf($key => 'invalid' =>  $data);
			} else {
				$data = $1;
								
				if (exists $spec->{'length'}) {
					$self->errorf($key => 'length', $data), next DATA 
							unless length($data) == $spec->{'length'};	
				}
				
				if (exists $spec->{'max_length'}) {
					$self->errorf($key => 'length', $data), next DATA 
						unless length($data) <= $spec->{'max_length'};
				}
				
				if (exists $spec->{'min_length'}) {
					$self->errorf($key => 'length', $data), next DATA 
						unless length($data) >= $spec->{'min_length'};
				}	
				
				if ($spec->{'extra_test'}) {
					foreach my $t (@{$spec->{'extra_test'}}) {
						unless ($t->(\$data, $self, $key)) {
							# Don't overide any error message that the test 
							# function set.
							$self->errorf($key => 'invalid', $data) 
								unless $self->{'errors'}->{$key};
							next DATA;
						}
					}
				}
				
				push(@new_data, $data);
			}		
		}
		
		if (@new_data) {
			$self->{'data'}->{$key} = [ @new_data ];
		} else {
			delete $self->{'data'}->{$key};
		}
		
		
		
	}
	
	#
	# clear out the spec of the cruft we don't need anymore...
	#
	# XXX -- this is temp to make things work with storable.
	#
	foreach my $param (keys %{$self->{'spec'}}) {
		delete $self->{'spec'}->{$param}->{'extra_test'};
		delete $self->{'spec'}->{$param}->{'filter'};
	}
}

	

sub params {
	my ($self) = @_;
	
	# Store it in an tmp array to force this into list context. 
	# (sort returns undef in non-list context.)
	my @params = sort keys %{$self->{'data'}};
	
	return @params;
}

sub param {
	my ($self, $name, $new_value) = @_;
	
	return $self->params unless $name;
	
	if (defined $new_value) {
		if (ref $new_value) {
			if (ref $new_value eq 'ARRAY') {
				$self->{'data'}->{$name} = $new_value;
			} else {
				Carp::croak("param(): new value is not data or an array reference.");
			}
		} else {
			$self->{'data'}->{$name} = [ $new_value ];
		}
	}
	
	return unless my $data = $self->{'data'}->{$name};
	
	return wantarray ? @{$data} : $data->[0];
}
	

sub error {
	my ($self, $name, $new_error) = @_;
	
	if ($name) {
		$self->{'errors'}->{$name} = $new_error if $new_error;
				
		return $self->{'errors'}->{$name};
	} else {
		return %{$self->{'errors'}} ? 1 : 0;
	}
}

sub errors { return %{$_[0]->{'errors'}}; }

sub errorf {
	my ($self, $key, $type, $data) = @_;
		
	my $format;

	unless ($self->{'spec'}->{$key}) {
		Carp::croak("errorf(): Invalid key: $key");
	}

	if ($self->{'spec'}->{$key}->{'errors'}) {
		$format = $self->{'spec'}->{$key}->{'errors'}->{$type} || $DefaultErrors{$type};
	} else {
		$format = $DefaultErrors{$type};
	}

	Carp::croak("errorf(): Invalid error type: $type") unless $format;
	
	my %map = (
		key   => $key,
		value => $data,
	);

	$format =~ s{\[%\s*(\w+)\s*%\]}{ $map{$1} || '' }egs;
	
	return $self->error($key => $format);
}

sub started {
	my ($self) = @_;
	
	return $self->{'in_unstarted_mode'} ? 0 : 1;
}

sub ready {
	return ($_[0]->started and not $_[0]->error);
}

sub AUTOLOAD {
	my $self = shift;

	our $AUTOLOAD;
	
	return if $AUTOLOAD =~ m/DESTROY/;
	$AUTOLOAD =~ m/^.*:(.*)$/;
	
	my $name = $1 || return;

	if ($self->{'spec'}->{$name}) {
		return $self->param($name, @_);
	} else {
		Carp::croak("Unknown method: $name");
	}
}

1;
__END__