view release on metacpan or  search on metacpan

lib/DBIx/DataModel/Statement.pm  view on Meta::CPAN

#----------------------------------------------------------------------
package DBIx::DataModel::Statement;
#----------------------------------------------------------------------
# see POD doc at end of file

use warnings;
use strict;
use List::MoreUtils  qw/firstval any/;
use Scalar::Util     qw/weaken dualvar/;
use POSIX            qw/LONG_MAX/;
use Clone            qw/clone/;
use DBIx::DataModel::Carp;
use Try::Tiny        qw/try catch/;
use mro              qw/c3/;

use DBIx::DataModel;
use DBIx::DataModel::Meta::Utils qw/define_readonly_accessors does/;
use namespace::clean;

#----------------------------------------------------------------------
# internals
#----------------------------------------------------------------------

use overload

  # overload the stringification operator so that Devel::StackTrace is happy;
  # also useful to show the SQL (if in sqlized state)
  '""' => sub {
    my $self = shift;
    my $string = try {my ($sql, @bind) = $self->sql;
                       __PACKAGE__ . "($sql // " . join(", ", @bind) . ")"; }
              || overload::StrVal($self);
  }
;


# sequence of states. Stored as dualvars for both ordering and printing
use constant {
  NEW      => dualvar(1, "new"     ),
  REFINED  => dualvar(2, "refined" ),
  SQLIZED  => dualvar(3, "sqlized" ),
  PREPARED => dualvar(4, "prepared"),
  EXECUTED => dualvar(5, "executed"),
};


# arguments accepted by the refine() method, and their associated handlers
my %REFINABLE_ARGS = (
  -where    => \&_merge_into_where_arg,
  -fetch    => \&_fetch_from_primary_key,
  -columns  => \&_restrict_columns,
  map {(-$_ => \&_just_store_arg)} qw/order_by        group_by  having    for
                                      union union_all intersect except    minus
                                      result_as       post_SQL  pre_exec  post_exec  post_bless
                                      limit           offset    page_size page_index as
                                      column_types    prepare_attrs       dbi_prepare_method
                                      where_on        join_with_USING     sql_abstract/,
 );


#----------------------------------------------------------------------
# PUBLIC METHODS
#----------------------------------------------------------------------

sub new {
  my ($class, $source, %other_args) = @_;

  # check $source
  $source 

lib/DBIx/DataModel/Statement.pm  view on Meta::CPAN

    # build a hash where keys are the database table names, and values are the join conditions (hashes)
    my %by_dest_table = reverse @other_join_args;

    # additional conditions coming from the -where_on hash are inserted as additional join criteria
    while (my ($table, $additional_cond) = each %$where_on) {
      my $db_table  = $meta_source->{db_table_by_source}{$table};
      no warnings 'uninitialized';
      my $join_cond =  $by_dest_table{$db_table} # new preferred syntax : through association or alias names
                    || $by_dest_table{$table}    # backwards compat : database names are accepted too
        or croak "-where_on => {'$table' => ..}: there is no such table in the join ", $meta_source->class;
      $join_cond->{condition}
        = $self->sql_abstract->merge_conditions($join_cond->{condition},
                                                $additional_cond);
      delete $join_cond->{using};
    }
  }

  # adjust join conditions for ON clause or for USING clause
  if (does $sqla_args{-from}, 'ARRAY') {
    $sqla_args{-from}[0] eq '-join'
      or croak "datasource is an arrayref but does not start with -join";
    my $join_with_USING
      = exists $args->{-join_with_USING} ? $args->{-join_with_USING}
                                         : $self->schema->{join_with_USING};
    for (my $i = 2; $i < @{$sqla_args{-from}}; $i += 2) {
      my $join_cond = $sqla_args{-from}[$i];
      if ($join_with_USING) {
        delete $join_cond->{condition} if $join_cond->{using};
      }
      else {
        delete $join_cond->{using};
      }
    }
  }

  # generate SQL
  my $sqla_result = $self->sql_abstract->select(%sqla_args);

  # maybe post-process the SQL
  if ($args->{-post_SQL}) {
    ($sqla_result->{sql}, @{$sqla_result->{bind}})
      = $args->{-post_SQL}->($sqla_result->{sql}, @{$sqla_result->{bind}});
  }

  # keep $sql / @bind / aliases in $self, and set new status
  $self->{bound_params} = $sqla_result->{bind};
  $self->{$_} = $sqla_result->{$_} for qw/sql aliased_tables aliased_columns/;
  $self->{status}       = SQLIZED;

  # analyze placeholders, and replace by pre_bound params if applicable
  if (my $regex = $self->{placeholder_regex}) {
    for (my $i = 0; $i < @{$self->{bound_params}}; $i++) {
      $self->{bound_params}[$i] =~ $regex 
        and push @{$self->{param_indices}{$1}}, $i;
    }
  }
  $self->bind($self->{pre_bound_params}) if $self->{pre_bound_params};

  # compute callback to apply to data rows
  my $callback = $self->{args}{-post_bless};
  weaken(my $weak_self = $self);   # weaken to avoid a circular ref in closure
  $self->{row_callback} = sub {
    my $row = shift;
    $weak_self->bless_from_DB($row);
    $callback->($row) if $callback;
  };

  return $self;
}



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

  my $meta_source = $self->meta_source;

  $self->sqlize(@args) if @args or $self->status < SQLIZED;

  $self->status == SQLIZED
    or croak "can't prepare() when in status " . $self->status;

  # log the statement and bind values
  $self->schema->_debug("PREPARE $self->{sql} / @{$self->{bound_params}}");

  # assemble stuff for calling the database
  my $dbh          = $self->schema->dbh or croak "Schema has no dbh";
  my $method       = $self->{args}{-dbi_prepare_method}  || $self->schema->dbi_prepare_method;
  my @prepare_args = ($self->{sql});
  if (my $prepare_attrs = $self->{args}{-prepare_attrs}) {
    push @prepare_args, $prepare_attrs;
  }

  # call the database
  $self->{sth}  = $dbh->$method(@prepare_args);

  # new status and return
  $self->{status} = PREPARED;
  return $self;
}



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

  $self->prepare              if $self->status < PREPARED;
  return $self->{sth};
}



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

  # if not prepared yet, prepare it
  $self->prepare               if $self->status < PREPARED;

  # bind arguments if any
  $self->bind(@bind_args)      if @bind_args;