view release on metacpan or  search on metacpan

lib/DBIx/DataModel/Source/Table.pm  view on Meta::CPAN

      croak "update() as instance method: too many arguments";
    }
  }

  return ($to_set, $where);
}


sub _apply_handlers_for_update {
  my ($self, $to_set, $where) = @_;

  # class of the invocant
  my $class  = ref $self || $self;

  # apply no_update and auto_update
  my %no_update_column = $self->metadm->no_update_column;
  delete $to_set->{$_} foreach keys %no_update_column;
  my %auto_update_column = $self->metadm->auto_update_column;
  while (my ($col, $handler) = each %auto_update_column) {
    $to_set->{$col} = $handler->($to_set, $class);
  }

  # apply 'to_DB' handlers. Need temporary bless as an object
  my $schema = $self->schema;
  $to_set->{__schema} = $schema; # in case the handlers need it
  bless $to_set, $class;
  $to_set->apply_column_handler('to_DB');
  delete $to_set->{__schema};
  $schema->unbless($to_set);


  # detect references to foreign objects
  my $sqla = $schema->sql_abstract;
  my @sub_refs;
  foreach my $key (keys %$to_set) {
    my $val     = $to_set->{$key};
    next if !ref $val;
    push @sub_refs, $key
      if does($val, 'HASH')
        ||( does($val, 'ARRAY')
              && !$sqla->{array_datatypes}
              && !$sqla->is_bind_value_with_type($val) );
    # reftypes SCALAR or REF are OK; they are used by SQLA for verbatim SQL
  }

  # remove references to foreign objects
  if (@sub_refs) {
    carp "data passed to update() contained nested references : ",
      CORE::join ", ", sort @sub_refs;
    delete @{$to_set}{@sub_refs};
  }

  # THINK : instead of removing references to foreign objects, one could
  # maybe perform recursive updates (including insert/update/delete of child
  # objects)
}




sub update  {
  my $self = shift;

  # prepare datastructures for generating the SQL
  my ($to_set, $where) = $self->_parse_update_args(@_);
  $self->_apply_handlers_for_update($to_set, $where);

  # database request
  my $schema       = $self->schema;
  my $sqla         = $schema->sql_abstract;
  my ($sql, @bind) = $sqla->update(
    -table => $self->db_from,
    -set   => $to_set,
    -where => $where,
   );
  $schema->_debug(do {no warnings 'uninitialized';
                      $sql . " / " . CORE::join(", ", @bind);});
  my $prepare_method = $schema->dbi_prepare_method;
  my $sth            = $schema->dbh->$prepare_method($sql);
  $sqla->bind_params($sth, @bind);
  return $sth->execute(); # will return the number of updated records
}


#------------------------------------------------------------
# utility methods
#------------------------------------------------------------

sub db_from {
  my $self = shift;

  my $db_from   = $self->metadm->db_from;
  my $db_schema = $self->schema->db_schema;

  # prefix table with $db_schema if non-empty and there is no hardwired db_schema
  return $db_schema && $db_from !~ /\./ ? "$db_schema.$db_from" : $db_from;
}

sub has_invalid_columns {
  my ($self) = @_;
  my $results = $self->apply_column_handler('validate');
  my @invalid;			# names of invalid columns
  while (my ($k, $v) = each %$results) {
    push @invalid, $k if defined($v) and not $v;
  }
  return @invalid ? \@invalid : undef;
}

sub _parse_ending_options {
  my ($class_or_self, $args_ref, $regex) = @_;

  # end of list may contain options, recognized because option name is a
  # scalar matching the given regex
  my %options;
  while (@$args_ref >= 2 && !ref $args_ref->[-2] 
                         && $args_ref->[-2] && $args_ref->[-2] =~ $regex) {
    my ($opt_val, $opt_name) = (pop @$args_ref, pop @$args_ref);
    $options{$opt_name} = $opt_val;
  }
  return \%options;
}