File Coverage

blib/lib/Maypole/Model/CDBI/FromCGI.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Maypole::Model::CDBI::FromCGI;
use strict;
use warnings;

=head1 NAME

Maypole::Model:CDBI::FromCGI - Validate form input and populate Model objects

=head1 SYNOPSIS

  $obj = $class->create_from_cgi($r);
  $obj = $class->create_from_cgi($r, { params => {data1=>...}, required => [..],
		 ignore => [...], all => [...]);
  $obj = $class->create_from_cgi($h, $options); # CDBI::FromCGI style, see docs

  $obj->update_from_cgi($r);
  $obj->update_from_cgi($h, $options);

  $obj = $obj->add_to_from_cgi($r);
  $obj = $obj->add_to_from_cgi($r, { params => {...} } );

  # This does not work like in CDBI::FromCGI and probably never will :
  # $class->update_from_cgi($h, @columns);


=head1 DESCRIPTION

Provides a way to validate form input and populate Model Objects, based
on Class::DBI::FromCGI.

=cut


# The base base model class for apps
# provides good search and create functions

use base qw(Exporter);
use CGI::Untaint;
use Maypole::Constants;
use CGI::Untaint::Maypole;
our $Untainter = 'CGI::Untaint::Maypole';

our @EXPORT = qw/update_from_cgi create_from_cgi untaint_columns add_to_from_cgi
    cgi_update_errors untaint_type validate_inputs validate_all _do_update_all
    _do_create_all _create_related classify_form_inputs/;



use Data::Dumper; # for debugging

=head1 METHODS

=head2 untaint_columns

Replicates Class::DBI::FromCGI method of same name :

  __PACKAGE__->untaint_columns(
    printable => [qw/Title Director/],
    integer   => [qw/DomesticGross NumExplodingSheep],
    date      => [qw/OpeningDate/],
  );

=cut

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);
}

=head2 untaint_type

  gets the  untaint type for a column as set in "untaint_types"

=cut

# get/set untaint_type for a column
sub untaint_type {
    my ($class, $field, $new_type) = @_;
    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;
}

=head2 cgi_update_errors

Returns errors that ocurred during an operation.

=cut

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

=head2 create_from_cgi

Based on the same method in Class::DBI::FromCGI.

Creates  multiple objects  from a  cgi form.
Errors are returned in cgi_update_errors

It can be called Maypole style passing the Maypole request object as the
first arg, or Class::DBI::FromCGI style passing the Untaint Handler ($h)
as the first arg.

A hashref of options can be passed as the second argument. Unlike
in the CDBI equivalent, you can *not* pass a list as the second argument.
Options can be :
 params -- hashref of cgi data to use instead of $r->params,
 required -- list of fields that are required
 ignore   -- list of fields to ignore
 all      -- list of all fields (defaults to $class->columns)

=cut

sub create_from_cgi {
  my ($self, $r, $opts) = @_;
  $self->_croak( "create_from_cgi can only be called as a class method")
    if ref $self;
  my ($errors, $validated);


  if ($r->isa('CGI::Untaint')) { # FromCGI interface compatibility
    ($validated, $errors) = $self->validate_inputs($r,$opts);
  } else {
    my $params = $opts->{params} || $r->params;
    $opts->{params} = $self->classify_form_inputs($params);
    ($validated, $errors) = $self->validate_all($r, $opts);
  }

  if (keys %$errors) {
    return bless { _cgi_update_error => $errors }, $self;
  }

  # Insert all the data
  my ($obj, $err ) = $self->_do_create_all($validated);
  if ($err) {
    return bless { _cgi_update_error => $err }, $self;
  }
  return $obj;
}


=head2 update_from_cgi

Replicates the Class::DBI::FromCGI method of same name. It updates an object and
returns 1 upon success. It can take the same arguments as create_form_cgi.
If errors, it sets the cgi_update_errors.

=cut

sub update_from_cgi {
  my ($self, $r, $opts) = @_;
  $self->_croak( "update_from_cgi can only be called as an object method") unless ref $self;
  my ($errors, $validated);
  $self->{_cgi_update_error} = {};
  $opts->{updating} = 1;

  # FromCGI interface compatibility
  if ($r->isa('CGI::Untaint')) {
    # REHASH the $opts for updating:
    # 1: we ignore any fields we dont have parmeter for. (safe ?)
    # 2: we dont want to update fields unless they change

    my @ignore = @{$opts->{ignore} || []};
    push @ignore, $self->primary_column->name;
    my $raw = $r->raw_data;
    #print "*** raw data ****" . Dumper($raw);
    foreach my $field ($self->columns) {
      #print "*** field is $field ***\n";
      	if (not defined $raw->{$field}) {
			push @ignore, $field->name;
			#print "*** ignoring $field because it is not present ***\n";
			next;
      	}
      	# stupid inflation , cant get at raw db value easy, must call
      	# deflate ***FIXME****
      	my $cur_val = ref $self->$field ? $self->$field->id : $self->$field;
      	if ($raw->{$field} eq $cur_val) {
			#print "*** ignoring $field because unchanged ***\n";
			push @ignore, "$field";
      	}
    }
    $opts->{ignore} = \@ignore;
    ($validated, $errors) = $self->validate_inputs($r,$opts);
  } else {
    my $params = $opts->{params} || $r->params;
    $opts->{params} = $self->classify_form_inputs($params);
    ($validated, $errors) = $self->validate_all($r, $opts);
    #print "*** errors for validate all   ****" . Dumper($errors);
  }

  if (keys %$errors) {
    #print "*** we have errors   ****" . Dumper($errors);
    $self->{_cgi_update_error} = $errors;
    return;
  }

  # Update all the data
  my ($obj, $err ) = $self->_do_update_all($validated);
  if ($err) {
    $self->{_cgi_update_error} = $err;
    return;
  }
  return 1;
}

=head2 add_to_from_cgi

$obj->add_to_from_cgi($r[, $opts]);

Like add_to_* for has_many relationships but will add nay objects it can
figure out from the data.  It returns a list of objects it creates or nothing
on error. Call cgi_update_errors with the calling object to get errors.
Fatal errors are in the respective "FATAL" key.

=cut

sub add_to_from_cgi {
  my ($self, $r, $opts) = @_;
  $self->_croak( "add_to_from_cgi can only be called as an object method")
    unless ref $self;
  my ($errors, $validated, @created);

  my $params = $opts->{params} || $r->params;
  $opts->{params} = $self->classify_form_inputs($params);
  ($validated, $errors) = $self->validate_all($r, $opts);


  if (keys %$errors) {
    $self->{_cgi_update_error} = $errors;
	return;
  }

  # Insert all the data
  foreach my $hm (keys %$validated) {
	my ($obj, $errs) = $self->_create_related($hm, $validated->{$hm});
	if (not $errs) {
		push @created, $obj;
	}else {
		$errors->{$hm} = $errs;
	}
  }

  if (keys %$errors) {
    $self->{_cgi_update_error} = $errors;
	return;
  }

  return @created;
}




=head2 validate_all

Validates (untaints) a hash of possibly mixed table data.
Returns validated and errors ($validated, $errors).
If no errors then undef in that spot.

=cut

sub validate_all {
  my ($self, $r, $opts) = @_;
  my $class = ref $self || $self;
  my $classified = $opts->{params};
  my $updating   = $opts->{updating};

  # Base case - validate this classes data
  $opts->{all}   ||= eval{ $r->config->{$self->table}{all_cols} } || [$self->columns('All')];
  $opts->{required} ||= eval { $r->config->{$self->table}{required_cols} || $self->required_columns } || [];
  my $ignore = $opts->{ignore} || eval{ $r->config->{$self->table}{ignore_cols} } || [];
  push @$ignore, $self->primary_column->name if $updating;

  # Ignore hashes of foreign inputs. This takes care of required has_a's
  # for main object that we have foreign inputs for.
  foreach (keys %$classified) {
    push @$ignore, $_ if  ref $classified->{$_} eq 'HASH';
  }
  $opts->{ignore} = $ignore;
  my $h = $Untainter->new($classified);
  my ($validated, $errs) = $self->validate_inputs($h, $opts);

  # Validate all foreign input

  #warn "Classified data is " . Dumper($classified);
  foreach my $field (keys %$classified) {
    if (ref $classified->{$field} eq "HASH") {
      my $data = $classified->{$field};
  	  my $ignore = [];
      my @usr_entered_vals = ();
      foreach ( values %$data ) {
		push @usr_entered_vals, $_  if $_  ne '';
      }

      # filled in values
      # IF we have some inputs for the related
      if ( @usr_entered_vals ) {
		# We need to ignore us if we are a required has_a in this foreign class
		my $rel_meta = $self->related_meta($r, $field);
	    my $fclass   = $rel_meta->{foreign_class};
		my $fmeta    = $fclass->meta_info('has_a');
		for (keys %$fmeta) {
			if ($fmeta->{$_}{foreign_class} eq $class) {
				push @$ignore, $_;
			}
		}
		my ($valid, $ferrs) = $fclass->validate_all($r,
		{params => $data, updating => $updating, ignore => $ignore } );

		$errs->{$field} = $ferrs if $ferrs;
		$validated->{$field} = $valid;

      } else {
		# Check this foreign object is not requeired
		my %req = map { $_ => 1 } $opts->{required};
		if ($req{$field}) {
	  		$errs->{$field}{FATAL} = "This is required. Please enter the required fields in this section."
			}
		}
  	}
  }
  #warn "Validated inputs are " . Dumper($validated);
  undef $errs unless keys %$errs;
  return ($validated, $errs);
}



=head2 validate_inputs

$self->validate_inputs($h, $opts);

This is the main validation method to validate inputs for a single class.
Most of the time you use validate_all.

Returns validated and errors.

If no errors then undef in that slot.

Note: This method is currently experimental (in 2.11) and may be subject to change
without notice.

=cut

sub validate_inputs {
  my ($self, $h, $opts) = @_;
  my $updating = $opts->{updating};
  my %required = map { $_ => 1 } @{$opts->{required}};
  my %seen;
  $seen{$_}++ foreach @{$opts->{ignore}};
  my $errors 	= {};
  my $fields 	= {};
  $opts->{all} = [ $self->columns ] unless @{$opts->{all} || [] } ;
  foreach my $field (@{$opts->{required}}, @{$opts->{all}}) {
    next if $seen{$field}++;
    my $type = $self->untaint_type($field) or
      do { warn "No untaint type for $self 's field $field. Ignoring.";
	   next;
	 };
    my $value = $h->extract("-as_$type" => $field);
    my $err = $h->error;

    # Required field error
    if ($required{$field} and !ref($value) and $err =~ /^No input for/) {
      $errors->{$field} = "You must supply '$field'"
    } elsif ($err) {

      # 1: No inupt entered
      if ($err =~ /^No input for/) {
				# A : Updating -- set the field to undef or ''
	if ($updating) {
	  $fields->{$field} = eval{$self->column_nullable($field)} ?
	    undef : '';
	}
				# B : Creating -- dont set a value and RDMS will put default
      }

      # 2: A real untaint error -- just set the error
      elsif ($err !~ /^No parameter for/) {
	$errors->{$field} =  $err;
      }
    } else {
      $fields->{$field} = $value
    }
  }
  undef $errors unless keys %$errors;
  return ($fields, $errors);
}


##################
# _do_create_all #
##################

# Untaints and Creates objects from hashed params.
# Returns parent object and errors ($obj, $errors).
# If no errors, then undef in that slot.
sub _do_create_all {
  my ($self, $validated) = @_;
  my $class = ref $self  || $self;
  my ($errors, $accssr);

  # Separate out related objects' data from main hash
  my %related;
  foreach (keys %$validated) {
    $related{$_}= delete $validated->{$_} if ref $validated->{$_} eq 'HASH';
  }

  # Make main object -- base case
  #warn "\n*** validated data is " . Dumper($validated). "***\n";
  my $me_obj  = eval { $self->create($validated) };
  if ($@) {
    warn "Just failed making a " . $self. " FATAL Error is $@"
      if (eval{$self->model_debug});
    $errors->{FATAL} = $@;
    return (undef, $errors);
  }

  if (eval{$self->model_debug}) {
    if ($me_obj) {
      warn "Just made a $self : $me_obj ( " . $me_obj->id . ")";
    } else {
      warn "Just failed making a " . $self. " FATAL Error is $@" if not $me_obj;
    }
  }

  # Make other related (must_have, might_have, has_many  etc )
  foreach $accssr ( keys %related ) {
    my ($rel_obj, $errs) =
      $me_obj->_create_related($accssr, $related{$accssr});
    $errors->{$accssr} = $errs if $errs;

  }
  #warn "Errors are " . Dumper($errors);

  undef $errors unless keys %$errors;
  return ($me_obj, $errors);
}


##################
# _do_update_all #
##################

#  Updates objects from hashed untainted data
# Returns 1

sub _do_update_all {
	my ($self, $validated) = @_;
	my ($errors, $accssr);

	#  Separate out related objects' data from main hash
	my %related;
	foreach (keys %$validated) {
		$related{$_}= delete $validated->{$_} if ref $validated->{$_} eq 'HASH';
	}
	# Update main obj
	# set does not work with IsA right now so we set each col individually
	#$self->set(%$validated);
	my $old = $self->autoupdate(0);
	for (keys %$validated) {
		$self->$_($validated->{$_});
	}
	$self->update;
	$self->autoupdate($old);

	# Update related
	foreach $accssr (keys %related) {
		my $fobj = $self->$accssr;
		my $validated = $related{$accssr};
		if ($fobj) {
			my $old = $fobj->autoupdate(0);
			for (keys %$validated) {
				$fobj->$_($validated->{$_});
			}
			$fobj->update;
			$fobj->autoupdate($old);
		}
		else {
			$fobj = $self->_create_related($accssr, $related{$accssr});
		}
	}
	return 1;
}


###################
# _create_related #
###################

# Creates and automatically relates newly created object to calling object
# Returns related object and errors ($obj, $errors).
# If no errors, then undef in that slot.

sub _create_related {
    # self is object or class, accssr is accssr to relationship, params are
    # data for relobject, and created is the array ref to store objs we
    # create (optional).
    my ( $self, $accssr, $params, $created )  = @_;
    $self->_croak ("Can't make related object without a parent $self object")
	unless ref $self;
    $created      ||= [];
    my  $rel_meta = $self->related_meta('r',$accssr);
    if (!$rel_meta) {
	$self->_carp("[_create_related] No relationship for $accssr in " . ref($self));
	return;
    }
    my $rel_type  = $rel_meta->{name};
    my $fclass    = $rel_meta->{foreign_class};
    #warn " Dumper of meta is " . Dumper($rel_meta);


    my ($rel, $errs);

    # Set up params for might_have, has_many, etc
    if ($rel_type ne 'has_own' and $rel_type ne 'has_a') {

	# Foreign Key meta data not very standardized in CDBI
	my $fkey= $rel_meta->{args}{foreign_key} || $rel_meta->{foreign_column};
	unless ($fkey) { die " Could not determine foreign key for $fclass"; }
	my %data = (%$params, $fkey => $self->id);
	%data = ( %data, %{$rel_meta->{args}->{constraint} || {}} );
	#warn "Data is " . Dumper(\%data);
	($rel, $errs) =  $fclass->_do_create_all(\%data, $created);
    }
    else {
	($rel, $errs) =  $fclass->_do_create_all($params, $created);
	unless ($errs) {
	    $self->$accssr($rel->id);
	    $self->update;
	}
    }
    return ($rel, $errs);
}




=head2  classify_form_inputs

$self->classify_form_inputs($params[, $delimiter]);

Foreign inputs are inputs that have data for a related table.
They come named so we can tell which related class they belong to.
This assumes the form : $accessor . $delimeter . $column recursively
classifies them into hashes. It returns a hashref.

=cut

sub classify_form_inputs {
	my ($self, $params, $delimiter) = @_;
	my %hashed = ();
	my $bottom_level;
	$delimiter ||= $self->foreign_input_delimiter;
	foreach my $input_name (keys %$params) {
		my @accssrs  = split /$delimiter/, $input_name;
		my $col_name = pop @accssrs;
		$bottom_level = \%hashed;
		while ( my $a  = shift @accssrs ) {
			$bottom_level->{$a} ||= {};
			$bottom_level = $bottom_level->{$a};  # point to bottom level
		}
		# now insert parameter at bottom level keyed on col name
		$bottom_level->{$col_name} = $params->{$input_name};
	}
	return  \%hashed;
}

sub _untaint_handlers {
    my ($me, $them) = @_;
    return () unless $them->can('__untaint_types');
    my %type = %{ $them->__untaint_types || {} };
    my %h;
    @h{ @{ $type{$_} } } = ($_) x @{ $type{$_} } foreach keys %type;
    return %h;
}

sub _column_type_for {
    my $type = lc shift;
    $type =~ s/\(.*//;
    my %map = (
        varchar   => 'printable',
        char      => 'printable',
        text      => 'printable',
        tinyint   => 'integer',
        smallint  => 'integer',
        mediumint => 'integer',
        int       => 'integer',
        integer   => 'integer',
        bigint    => 'integer',
        year      => 'integer',
        date      => 'date',
    );
    return $map{$type} || "";
}

=head1 MAINTAINER

Maypole Developers

=head1 AUTHORS

Peter Speltz, Aaron Trevena

=head1 AUTHORS EMERITUS

Tony Bowden

=head1 TODO

* Tests
* add_to_from_cgi, search_from_cgi
* complete documentation
* ensure full backward compatibility with Class::DBI::FromCGI

=head1 BUGS and QUERIES

Please direct all correspondence regarding this module to:
 Maypole list.

=head1 COPYRIGHT AND LICENSE

Copyright 2003-2004 by Peter Speltz

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=head1 SEE ALSO

L, L

=cut

1;