File Coverage

blib/lib/DBR/Record/Helper.pm

Criterion	Covered	Total	%
statement	197	203	97.0
branch	65	120	54.1
condition	16	20	80.0
subroutine	20	20	100.0
pod	0	6	0.0
total	298	369	80.7

package DBR::Record::Helper;

use strict;
use base 'DBR::Common';
use Carp;
use DBR::Query::Part;
use DBR::Query::Select;
use DBR::Query::Update;
use DBR::Query::Delete;
use DBR::ResultSet;
use DBR::ResultSet::Empty;
use DBR::Misc::Dummy;

# we can get away with making these once for all time
use constant ({
	       EMPTY => bless( [], 'DBR::ResultSet::Empty'),
	       DUMMY => bless( [], 'DBR::Misc::Dummy'),
	      });
sub new {
      my( $package ) = shift;
      my %params = @_;
      my $self = {
		  session  => $params{session},
		  instance => $params{instance},
		  tablemap => $params{tablemap},
		  flookup  => $params{flookup},
		  pkmap    => $params{pkmap},
		  scope    => $params{scope},
		  lastidx  => $params{lastidx},
		 };

      bless( $self, $package ); # BS object

      $self->{session}  or return $self->_error('session is required');
      $self->{instance} or return $self->_error('instance is required');
      $self->{scope}    or return $self->_error('scope is required');

      $self->{tablemap} or return $self->_error('tablemap is required');
      $self->{pkmap}    or return $self->_error('pkmap is required');           # X
      $self->{flookup}  or return $self->_error('flookup is required');         # X
      defined($self->{lastidx}) or return $self->_error('lastidx is required');

      return $self;
}

sub set{
      my $self = shift;
      my $record = shift;
      my %params = @_;

      my %sets;
      foreach my $fieldname (keys %params){
	    my $field = $self->{flookup}->{$fieldname} or return $self->_error("$fieldname is not a valid field");
	    $field->is_readonly && return $self->_error("Field $fieldname is readonly");

	    my $setvalue = $field->makevalue($params{$fieldname}) or return $self->_error('failed to create setvalue object');
	    $setvalue->count == 1 or return $self->_error("Field ${\$field->name} allows only a single value");

	    my $setobj   = DBR::Query::Part::Set->new( $field, $setvalue ) or return $self->_error('failed to create set object');

	    push @{$sets{$field->table_id}}, $setobj;
      }
      my $ct = scalar(keys %sets);

      return $self->_error('Must specify at least one field to set') unless $ct > 0;

      my $dbrh;
      if($ct > 1){
	    # create a new DBRH here to ensure proper transactional handling
	    $dbrh = $self->{instance}->connect or return $self->_error('failed to connect');
	    $dbrh->begin;
      }

      foreach my $table_id (keys %sets){
	    $self->_set($record, $table_id, $sets{$table_id}) or return $self->_error('failed to set');
      }

      $dbrh->commit if $ct > 1;

      return 1;
}

# set a field REGARDLESS of whether it was prefetched or not
sub setfield{
      my $self = shift;
      my $record = shift;
      my $field = shift;
      my $value = shift;

      my $setvalue = $field->makevalue($value) or return $self->_error('failed to create value object');
      $setvalue->count == 1 or return $self->_error("Value of ${\$field->name} must have only a single value");

      my $setobj   = DBR::Query::Part::Set->new( $field, $setvalue ) or return $self->_error('failed to create set object');

      return $self->_set($record, $field->table_id, [$setobj]);
}

sub _set{
      my $self = shift;
      my $record = shift;
      my $table_id = shift;
      my $sets = shift;

      my ($outwhere,$table) = $self->_pk_where($record,$table_id) or return $self->_error('failed to create where tree');

      my $query = DBR::Query::Update->new(
					  session  => $self->{session},
					  instance => $self->{instance},
					  tables   => $table,
					  where    => $outwhere,
					  sets     => $sets
					 ) or return $self->_error('failed to create Query object');

      my $rv = $query->run() or return $self->_error('failed to execute');

      foreach my $set (@$sets){
	    $self->_setlocalval($record, $set->field, $set->value->raw->[0]);
      }

      return $rv;
}

sub delete{
       my $self = shift;
       my $record = shift;

       return $self->_error('Cannot call delete on join record')
	 if scalar(keys %{$self->{tablemap}}) > 1;

       my ($table_id) = keys %{$self->{tablemap}};

       my ($outwhere,$table) = $self->_pk_where($record,$table_id) or return $self->_error('failed to create where tree');

       my $query = DBR::Query::Delete->new(
					   session  => $self->{session},
					   instance => $self->{instance},
					   tables   => $table,
					   where    => $outwhere,
					  ) or return $self->_error('failed to create Query object');

       $query->run or return $self->_error('failed to execute');

       return 1;
}


# Fetch a field ONLY if it was not prefetched
sub getfield{
       my $self = shift;
       my $record = shift;
       my $field = shift;
       my $want_sref = shift;

       # Check to see if we've previously been assigned an index. if so, see if our record already has it fetched
       # This could happen if the field was not fetched in the master query, but was already fetched with getfield
       my $idx = $field->index;
       return $record->[$idx] if defined($idx) && exists($record->[$idx]);

       $self->{scope}->addfield($field) or return $self->_error('Failed to add field to scope');

       my ($outwhere,$table)  = $self->_pk_where($record,$field->table_id) or return $self->_error('failed to create where tree');

       # Because we are doing a new select, which will set the indexes on
       # its fields, we must clone the field provided by the original query
       my $newfield = $field->clone;

       my $query = DBR::Query::Select->new(
					   session  => $self->{session},
					   instance => $self->{instance},
					   tables   => $table,
					   where    => $outwhere,
					   fields   => [ $newfield ] # use the new cloned field
					  ) or return $self->_error('failed to create Query object');

       my $sth = $query->run or return $self->_error('failed to execute');

       $sth->execute() or return $self->_error('Failed to execute sth');
       my $row  = $sth->fetchrow_arrayref() or return $self->_error('Failed to fetchrow');

       my $val = $row->[ $newfield->index ];

       $self->_setlocalval($record,$field,$val);

       return $want_sref?\$val:$val; # return a scalarref if requested
}

sub getrelation{
      my $self = shift;
      my $obj = shift;
      my $relation = shift;
      my $field  = shift;

      my $record = $obj->[0];
      my $buddy  = $obj->[1];
      my $rowcache = $buddy->[0];

      my $ridx = $relation->index;
      # Check to see if this record has a cached version of the resultset
      return $record->[$ridx] if defined($ridx) && exists($record->[$ridx]); # skip the rest if we have that

      my $fidx = $field->index();
      my $val;

      my $to1 = $relation->is_to_one;                                                        # Candidate for pre-processing
      my $table    = $relation->table    or return $self->_error('Failed to fetch table'   );# Candidate for pre-processing
      my $maptable = $relation->maptable or return $self->_error('Failed to fetch maptable');# Candidate for pre-processing
      my $mapfield = $relation->mapfield or return $self->_error('Failed to fetch mapfield');# Candidate for pre-processing

      my @allvals; # For uniq-ing

      if( defined($fidx) && exists($record->[$fidx]) ){
	    $val = $record->[ $fidx ]; # My value
	    @allvals = $self->_uniq( $val, map { $_->[ $fidx ] } grep {defined} @$rowcache ); # look forward in the rowcache and add those too
      }else{
	    # I forget, I think I'm using scalar ref as a way to represent undef and still have a true rvalue *ugh*
	    my $sref = $self->getfield($record,$field, 1 ); # go fetch the value in the form of a scalarref
	    defined ($sref) or return $self->_error("failed to fetch the value of ${\ $field->name }");
	    $val = $$sref;
	    $fidx ||= $field->index;
	    confess('field object STILL does not have an index') unless defined($fidx);
	    push @allvals, $val;
      }

      my $rowcount = scalar @allvals; # Cheapest way to get a rowcount is here, before we filter

      unless($mapfield->is_nullable){ # Candidate for pre-defined global
	    @allvals = grep { defined } @allvals;
      }

      unless(scalar @allvals){
	    # no values? then for sure, the relationship for this record must be empty.
	    # Cache the emptyness so we don't have to repeat this work
	    return $self->_setlocalval( $record, $relation, $to1 ? DUMMY : EMPTY );
      }

      my $value    = $mapfield->makevalue( \@allvals );
      my $outwhere = DBR::Query::Part::Compare->new( field => $mapfield, value => $value );

      my $scope = DBR::Config::Scope->new(
					  session       => $self->{session},
					  conf_instance => $maptable->conf_instance,
					  extra_ident   => $maptable->name,
					  offset        => 2,  # because getrelation is being called indirectly, look at the scope two levels up
					 ) or return $self->_error('Failed to get calling scope');

      my $pk        = $maptable->primary_key or return $self->_error('Failed to fetch primary key');
      my $prefields = $scope->fields or return $self->_error('Failed to determine fields to retrieve');

      my %uniq;
      my @fields = grep { !$uniq{ $_->field_id }++ } ($mapfield, @$pk, @$prefields );

      my $mapinstance = $self->{instance};
      unless ( $relation->is_same_schema ){
	    $mapinstance = $maptable->schema->get_instance( $mapinstance->class ) or return $self->_error('Failed to retrieve db instance for the maptable');
      }

      $self->_logDebug2( "Relationship from instance " . $self->{instance}->guid . "->" . $mapinstance->guid );
      my $query = DBR::Query::Select->new(
					  session  => $self->{session},
					  instance => $mapinstance,
					  tables   => $maptable,
					  where    => $outwhere,
					  fields   => \@fields,
					  scope    => $scope,
					  splitfield  => $mapfield
					 ) or return $self->_error('failed to create Query object');


      if($rowcount > 1){
	    my $myresult;
	    if($to1){
		  my $resultset =  DBR::ResultSet->new( $query ) or croak('Failed to create resultset');
		  $self->_logDebug2('mapping to individual records');
		  my $resultmap = $resultset->hashmap_single(  $mapfield->name  ) or return $self->_error('failed to split resultset');

		  # look forward in the rowcache and assign the resultsets for whatever we find
		  foreach my $row (grep {defined} @$rowcache) {
			$self->_setlocalval(
					    $row,
					    $relation,
					    $resultmap->{ $row->[$fidx] } || DUMMY
					   );
		  }

		  $myresult = $resultmap->{$val} || DUMMY;

	    }else{
		  # look forward in the rowcache and assign the resultsets for whatever we find
		  foreach my $row (grep {defined} @$rowcache) {
			$self->_setlocalval($row,
					    $relation,
					    DBR::ResultSet->new( $query, $row->[$fidx] )
					   );
		  }

		  $myresult = DBR::ResultSet->new( $query, $val );
	    }

	    $self->_setlocalval($record,$relation,$myresult);

	    return $myresult;

      }else{
	    my $resultset =  DBR::ResultSet->new( $query ) or croak('Failed to create resultset');
	    my $result = $resultset;
	    if($to1){
		  $result = $resultset->next;
	    }

	    $self->_setlocalval($record,$relation,$result);

	    return $result;
      }
}

sub _pk_where{
      my $self = shift;
      my $record = shift;
      my $table_id = shift;

      my $table = $self->{tablemap}->{ $table_id } || return $self->_error('Missing table for table_id ' . $table_id );
      my $pk    = $self->{pkmap}->{ $table_id }    || return $self->_error('Missing primary key');

      my @and;
      foreach my $part (@{ $pk }){

	    my $value = $part->makevalue( $record->[ $part->index ] ) or return $self->_error('failed to create value object');
	    my $outfield = DBR::Query::Part::Compare->new( field => $part, value => $value ) or return $self->_error('failed to create compare object');

	    push @and, $outfield;
      }


      return (DBR::Query::Part::And->new(@and), $table);
}

sub _setlocalval{
      my $self   = shift;
      my $record = shift;
      my $field  = shift; # Could also be a relationship object
      my $val    = shift;

      my $idx = $field->index;
      # update the field object to give it an index if necessary
      if(!defined $idx){ #Could be 0
	    $idx = ++$self->{lastidx};
	    $field->index($idx); # so we'll have it for next time this gets accessed
      }

      # Update this record to reflect the new value
      return $record->[$idx] = $val;
}

1;