view release on metacpan or  search on metacpan

lib/Class/DBI/FromCGI.pm  view on Meta::CPAN

package Class::DBI::FromCGI;

$VERSION = '1.00';

use strict;
use Exporter;

use vars qw/@ISA @EXPORT/;
use base 'Exporter';
@EXPORT = qw/update_from_cgi create_from_cgi untaint_columns
	cgi_update_errors untaint_type/;

sub untaint_columns {
	die "untaint_columns() needs a hash" unless @_ % 2;
	my ($class, %args) = @_;
	$class->mk_classdata('__untaint_types')
		unless $class->can('__untaint_types');
	my %types = %{ $class->__untaint_types || {} };
	while (my ($type, $ref) = each(%args)) {
		$types{$type} = $ref;
	}
	$class->__untaint_types(\%types);
}

sub cgi_update_errors { %{ shift->{_cgi_update_error} || {} } }

sub update_from_cgi {
	my $self = shift;
	die "update_from_cgi cannot be called as a class method" unless ref $self;
	__PACKAGE__->_run_update($self, @_);
}

sub create_from_cgi {
	my $class = shift;
	die "create_from_cgi can only be called as a class method" if ref $class;
	__PACKAGE__->_run_create($class, @_);
}

sub untaint_type {
	my ($class, $field) = @_;
	my %handler = __PACKAGE__->_untaint_handlers($class);
	return $handler{$field} if $handler{$field};
	my $handler = eval {
		local $SIG{__WARN__} = sub { };
		my $type = $class->column_type($field) or die;
		_column_type_for($type);
	};
	return $handler || undef;
}

#----------------------------------------------------------------------

sub _validate {
	my ($me, $them, $h, $wanted, $extra_ignore) = @_;

	my %wanted = $me->_parse_columns($them => @$wanted);
	my %required = map { $_ => 1 } @{ $wanted{required} };

	my %seen;
	$seen{$_}++ foreach @$extra_ignore, @{ $wanted{ignore} };

	$them->{_cgi_update_error} = {};
	my $fields = {};
	foreach my $field (@{ $wanted{required} }, @{ $wanted{all} }) {
		next if $seen{$field}++;
		my $type = $them->untaint_type($field) or next;
		my $value = $h->extract("-as_$type" => $field);
		my $err = $h->error;
		if ($required{$field} and not $value) {
			$them->{_cgi_update_error}->{$field} = "You must supply '$field'";
		} elsif ($err) {
			$them->{_cgi_update_error}->{$field} = $err
				unless $err =~ /^No parameter for/;
		} else {
			$fields->{$field} = $value;
		}
	}
	return ($them, $fields);
}

sub _run_update {
	my ($me, $them, $h, @wanted) = @_;
	my $class = ref($them);

	my $to_update;
	($them, $to_update) =
		$me->_validate($them, $h, \@wanted, [ $them->primary_column ]);