view release on metacpan or  search on metacpan

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

sub _just_store_arg {
  my ($self, $k, $v) = @_;
  $self->{args}{$k} = $v;
}

sub _merge_into_where_arg {
  my ($self, $k, $v) = @_;
  $self->{args}{-where} = $self->sql_abstract->merge_conditions($self->{args}{-where}, $v);
}

sub _fetch_from_primary_key {
  my ($self, $k, $v) = @_;

  # gather info for primary key
  my $primary_key = ref($v) ? $v : [$v];
  my @pk_columns  = $self->meta_source->primary_key;
  @pk_columns
    or croak "fetch: no primary key in source " . $self->meta_source;
  @pk_columns == @$primary_key
    or croak sprintf "fetch from %s: primary key should have %d values",
                     $self->meta_source, scalar(@pk_columns);
  List::MoreUtils::all {defined $_} @$primary_key
    or croak "fetch from " . $self->meta_source . ": "
           . "undefined val in primary key";

  # build a -where clause on primary key
  my %where = ();
  @where{@pk_columns} = @$primary_key;
  $self->{args}{-where} = $self->sql_abstract->merge_conditions($self->{args}{-where}, \%where);

  # want a single record as result
  $self->{args}{-result_as} = "firstrow";
}

sub _restrict_columns {
  my ($self, $k, $v) = @_;

  my @cols = does($v, 'ARRAY') ? @$v : ($v);
  if (my $old_cols = $self->{args}{-columns}) {
    unless (@$old_cols == 1 && $old_cols->[0] eq '*' ) {
      foreach my $col (@cols) {
        any {$_ eq $col} @$old_cols
          or croak "can't restrict -columns on '$col' (was not in the) "
                 . "previous -columns list";
      }
    }
  }
  $self->{args}{-columns} = \@cols;
}




#----------------------------------------------------------------------
# PRIVATE METHODS IN RELATION WITH select()
#----------------------------------------------------------------------


sub _forbid_callbacks {
  my ($self, $subclass) = @_;

  my $callbacks = CORE::join ", ", grep {$self->arg($_)} 
                                        qw/-pre_exec -post_exec -post_bless/;
  if ($callbacks) {
    $subclass =~ s/^.*:://;
    croak "$callbacks incompatible with -result_as=>'$subclass'";
  }
}



sub _next_and_finish {
  my $self = shift;
  my $row_or_rows = $self->next( @_ ); # pass original parameters
  $self->finish;
  return $row_or_rows;
}

sub _compute_from_DB_handlers {
  my ($self) = @_;
  my $meta_source    = $self->meta_source;
  my $meta_schema    = $self->schema->metadm;
  my %handlers       = $meta_source->_consolidate_hash('column_handlers');
  my %aliased_tables = $meta_source->aliased_tables;

  # iterate over aliased_columns
  while (my ($alias, $column) = each %{$self->{aliased_columns} || {}}) {
    my $table_name;
    $column =~ s{^([^()]+)     # supposed table name (without parens)
                  \.           # followed by a dot
                  (?=[^()]+$)  # followed by supposed col name (without parens)
                }{}x
      and $table_name = $1;
    if (!$table_name) {
      $handlers{$alias} = $handlers{$column};
    }
    else {
      $table_name = $aliased_tables{$table_name} || $table_name;

      my $table   = $meta_schema->table($table_name)
                 || (firstval {($_->{db_name} || '') eq $table_name}
                              ($meta_source, $meta_source->ancestors))
                 || (firstval {uc($_->{db_name} || '') eq uc($table_name)}
                              ($meta_source, $meta_source->ancestors))
        or croak "unknown table name: $table_name";

      $handlers{$alias} = $table->{column_handlers}->{$column};
    }
  }

  # handlers may be overridden from args{-column_types}
  if (my $col_types = $self->{args}{-column_types}) {
    while (my ($type_name, $columns) = each %$col_types) {
      $columns = [$columns] unless does $columns, 'ARRAY';
      my $type = $self->schema->metadm->type($type_name)
        or croak "no such column type: $type_name";
      $handlers{$_} = $type->{handlers} foreach @$columns;
    }
  }

  # just keep the "from_DB" handlers
  my $from_DB_handlers = {};
  while (my ($column, $col_handlers) = each %handlers) {
    my $from_DB_handler = $col_handlers->{from_DB} or next;
    $from_DB_handlers->{$column} = $from_DB_handler;
  }