File Coverage

blib/lib/DBIx/RoboQuery/ResultSet.pm

Criterion	Covered	Total	%
statement	142	146	97.2
branch	40	54	74.0
condition	14	23	60.8
subroutine	18	21	85.7
pod	14	14	100.0
total	228	258	88.3

# vim: set ts=2 sts=2 sw=2 expandtab smarttab:
#
# This file is part of DBIx-RoboQuery
#
# This software is copyright (c) 2010 by Randy Stauner.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
use strict;
use warnings;

package DBIx::RoboQuery::ResultSet;
{
  $DBIx::RoboQuery::ResultSet::VERSION = '0.032';
}
BEGIN {
  $DBIx::RoboQuery::ResultSet::AUTHORITY = 'cpan:RWSTAUNER';
}
# ABSTRACT: Configure the results to get what you want

use Carp qw(croak carp);
use Timer::Simple;


sub new {
  my $class = shift;
  my $query = shift;
  my %opts = ref($_[0]) eq 'HASH' ? %{$_[0]} : @_;
  my $self = {
    row_count     => -1,
    times         => {},
    query => $query,
    default_slice => {},

    # Process the template in case it changes anything (like query.key_columns)
    # so that everything will get passed to the ResultSet.
    sql => $query->sql(),
  };

  bless $self, $class;

  foreach my $var ( $self->_pass_through_args() ){
    # allow options to be specified directly
    if( exists($opts{$var}) ){
      $self->{$var} = $opts{$var};
    }
    # or look for them on the query object
    elsif( exists($query->{$var}) ){
      $self->{$var} = $query->{$var};
    }
  }

  DBIx::RoboQuery::Util::_ensure_arrayrefs($self);

  $self->{hash_key_name} ||=
    ($self->{dbh} && $self->{dbh}{FetchHashKeyName})
    || 'NAME_lc';

  return $self;
}


sub array {
  my ($self, @args) = @_;

  # default to an array of hashrefs if no arguments are given
  @args = $self->{default_slice}
    unless @args;

  $self->execute() if !$self->{executed};

  croak('Columns unknown.  Was this a SELECT?')
    unless $self->{all_columns};

  my @tr_args = ();
  if( @args ){
    # if the slice is empty, fill it with the non-drop_columns
    my $slice = $args[0];
    if( ref($slice) eq 'HASH' and !keys(%$slice) ){
      $slice->{$_} = 1 for $self->columns;
    }
    elsif( ref($slice) eq 'ARRAY' and !@$slice ){
      my @col  = @{$self->{all_columns}};
      my %drop = map { $_ => 1 } @{ $self->{drop_columns} };
      # turn [] into a list of (possibly non-contiguous) indexes: [1,2,4,5]
      push(@$slice, grep { !$drop{ $col[$_] } } 0 .. $#col);
      # set the first (only) element to an arrayref of column names
      @tr_args = ( [@col[@$slice]] );
    }
  }

  my $tr = $self->{transformations};
  my $t = Timer::Simple->new;

  my $rows = $self->{sth}->fetchall_arrayref(@args);
  $rows = [map { $tr->call(@tr_args, $_) } @$rows]
    if $tr;

  # include transformations in the time for consistency with hash()
  $self->{times}{fetch} = $t->stop;
  $self->{row_count} = @$rows;

  return $rows;
}

# convenience method for subclasses

sub _arrayref_args {
  my ($self) = @_;
  return $self->{query}->_arrayref_args;
}


sub bound_params { $_[0]->query->bound_params }
sub bound_values { $_[0]->query->bound_values }


sub columns {
  my ($self) = @_;
  croak('Columns not known until after the statement has executed')
    unless $self->{executed};
  return @{ $self->{columns} };
}


sub drop_columns {
  return @{$_[0]->{drop_columns}};
}


sub execute {
  my ($self, @params) = @_;

  # the sql attribute is cached from $query->sql in the constructor
  my $sql = $self->{sql};

  my $t = Timer::Simple->new;
  my $sth = $self->{sth} = $self->{dbh}->prepare($sql)
    or croak $self->{dbh}->errstr;
  $self->{times}{prepare} = $t->stop;

  # call bind_param() regardless of @params b/c bind_param can specify a type
  if( my $bind = $self->{bind_params} ){
    local $_;
    $sth->bind_param(@$_) for @$bind;
  }

  $t->restart;
  $self->{executed} = $sth->execute(@params)
    or croak $sth->errstr;
  $self->{times}{execute} = $t->stop;

  if( my $columns = $sth->{ $self->{hash_key_name} } ){
    # save the full order for later (but break the reference)
    $self->{all_columns} = [@$columns];

    # cache groups of column names
    foreach my $set (
      # preserve the order of non-dropped columns
      [qw(         columns all_columns drop_columns )],
      # make the list of non-key columns available separately
      [qw( non_key_columns     columns  key_columns )],
    ){
      my ($make, $from, $minus) = @$set;
      my %other = map { ($_ => 1) } @{ $self->{ $minus } };
      $self->{ $make } = [ grep { !$other{$_} } @{ $self->{ $from } } ];
    }

    if( my $transformations = $self->{transformations} ){
      foreach my $groups (
        [key => $self->{key_columns}],
        [non_key => $self->{non_key_columns}],
        # aliases
        [key_columns => {in => 'key'}],
        [non_key_columns => {in => 'non_key'}],
      ){
        $transformations->group(@$groups);
      }
      # set all the columns so we can use group exclusions
      $transformations->fields(@$columns);
    }
  }

  # FIXME: check $sth->errstr (or someting: see DBI)
  # to make sure we got all records without error

  return $self->{executed};
}


sub hash {
  my ($self) = @_;
  $self->execute() if !$self->{executed};
  # TODO: care if this is called more than once?
  my $sth = $self->{sth};

  my @key_columns  = @{ $self->{key_columns}  }
    or croak('Cannot use hash() with an empty key_columns attribute');

  # We could just return $sth->fetchall_hashref(\@key_columns) if there are
  # no preferences but we can't slice out the dropped columns that way.

  my @drop_columns = @{ $self->{drop_columns} };
  my @columns = (@key_columns, @{ $self->{non_key_columns} });

  # we have to save the dropped columns so we can send them to preference()
  my ($root, $dropped) = ({}, {});

  # NOTE: It seemed to me more powerful to transform the data upon fetch
  # rather than upon storage in the tree: it gives you the option of
  # pre-transforming the keys to adjust the way the tree is built
  # and lets you know what to expect in the preference rules.
  # Plus it was easier to implement.
  # I can't think of a reason to want transform the key columns in the record
  # but not the tree (ex: {A => {B => {k1 => 'a', k2 => 'b'}}})
  # If you want un-adultered data for preferences you can select the column
  # again with an alias and then drop it.

  my $tr = $self->{transformations};

  # we only increase the row count for new (not overridden) hashes
  my $count = 0;
  my $t = Timer::Simple->new;

  # check for preferences once... if there are none, do the quick version
  if( !$self->{preferences} || !@{$self->{preferences}} ){
    # we can't honor drop_columns with fetchall_hashref(), so fake it
    while( my $row = $sth->fetchrow_hashref() ){
      $row = $tr->call($row) if $tr;
      my $hash = $root;
      $hash = ($hash->{ $row->{$_} } ||= {}) for @key_columns;
      ++$count unless keys %$hash;
      @$hash{@columns}  = @$row{@columns};
    }
  }
  else {
    while( my $row = $sth->fetchrow_hashref() ){
      $row = $tr->call($row) if $tr;
      my ($hash, $drop) = ($root, $dropped);
      # traverse hash tree to get to {key1 => {key2 => {record}}}
      foreach ( @key_columns ){
        $hash = ($hash->{ $row->{$_} } ||= {});
        $drop = ($drop->{ $row->{$_} } ||= {});
      }
      # if there's already a record there (not an empty hash)
      # (a few benchmarks suggest keys() may be faster than exists())
      if( keys %$hash ){
        $row = $self->preference({%$drop, %$hash}, $row);
      }
      else {
        ++$count;
      }
      @$drop{@drop_columns} = @$row{@drop_columns};
      @$hash{@columns}  = @$row{@columns};
    }
  }
  $self->{times}{fetch} = $t->stop;
  $self->{row_count} = $count;
  return $root;
}


sub key_columns {
  my ($self) = @_;
  return @{$self->{key_columns}};
}


sub non_key_columns {
  my ($self) = @_;
  croak('Columns not known until after the statement has executed')
    unless $self->{executed};
  # An empty array should mean that the rest are key or drop columns.
  # If not defined, there's a problem.
  croak('Columns unknown.  Was this a SELECT?')
    unless $self->{non_key_columns};
  return @{$self->{non_key_columns}};
}

# convenience method: args allowed in the constructor

sub _pass_through_args {
  (
    $_[0]->_arrayref_args,
  qw(
    dbh
    default_slice
    hash_key_name
    preferences
    transformations
  ));
}


sub preference {
  my ($self, @records) = @_;
  my $rules = $self->{preferences};

  # return last record if there are no preferences
  return $records[-1]
    if !$rules || !@$rules;

  foreach my $rule ( @$rules ){
    my $template = "[% IF $rule %]1[% ELSE %]0[% END %]";
    # reverse records so that if any are equal the last one in wins
    foreach my $record ( reverse @records ){
      my $found = $self->{query}->_process_template(\$template, $record);
      return $record if $found;
    }
  }
  # last record is DBI compatibile plus it is often the newest record
  return $records[-1];
}


sub query {
  return $_[0]->{query};
}


sub row_count {
  return $_[0]->{row_count};
}


sub times {
  my ($self) = @_;
  my %times = %{ $self->{times} };
  $times{total} = $times{prepare} + $times{execute} + $times{fetch};
  return \%times;
}

# The DBI objects clean up after themselves, so DESTROY not currently warranted

1;

__END__