DBIO

 view release on metacpan or  search on metacpan

lib/DBIO/ResultSet.pm  view on Meta::CPAN

      # if all else fails - get all primary keys and operate over a ORed set
      # wrap in a transaction for consistency
      # this is where the group_by/multiplication starts to matter
      if (
        $existing_group_by
          or
        # we do not need to check pre-multipliers, since if the premulti is there, its
        # parent (who is multi) will be there too
        keys %{ $join_classifications->{multiplying} || {} }
      ) {
        # make sure if there is a supplied group_by it matches the columns compiled above
        # perfectly. Anything else can not be sanely executed on most databases so croak
        # right then and there
        if ($existing_group_by) {
          my @current_group_by = map
            { $_ =~ /\./ ? $_ : "$attrs->{alias}.$_" }
            @$existing_group_by
          ;

          if (
            join ("\x00", sort @current_group_by)
              ne
            join ("\x00", sort @{$attrs->{columns}} )
          ) {
            $self->throw_exception (
              "You have just attempted a $op operation on a resultset which does group_by"
              . ' on columns other than the primary keys, while DBIO internally needs to retrieve'
              . ' the primary keys in a subselect. All sane RDBMS engines do not support this'
              . ' kind of queries. Please retry the operation with a modified group_by or'
              . ' without using one at all.'
            );
          }
        }

        $subrs = $subrs->search({}, { group_by => $attrs->{columns} });
      }

      $guard = $storage->txn_scope_guard;

      for my $row ($subrs->cursor->all) {
        push @$cond, { map
          { $idcols->[$_] => $row->[$_] }
          (0 .. $#$idcols)
        };
      }
    }
  }

  my $res = $cond ? $storage->$op (
    $rsrc,
    $op eq 'update' ? $values : (),
    $cond,
  ) : '0E0';

  $guard->commit if $guard;

  return $res;
}


sub update {
  my ($self, $values, $options) = @_;
  $self->throw_exception('Values for update must be a hash')
    unless ref $values eq 'HASH';
  $self->_assert_restricted_or_all('update', $options);

  # no row is involved: every value goes to the storage as it is
  assert_column_value($_, $values->{$_}) for sort keys %$values;

  return $self->_rs_update_delete ('update', $values);
}


sub update_all {
  my ($self, $values, $options) = @_;
  $self->throw_exception('Values for update_all must be a hash')
    unless ref $values eq 'HASH';
  $self->_assert_restricted_or_all('update_all', $options);

  my $guard = $self->result_source->schema->txn_scope_guard;
  $_->update({%$values}) for $self->all;  # shallow copy - update will mangle it
  $guard->commit;
  return 1;
}


sub delete {
  my ($self, $options) = @_;
  $self->_assert_restricted_or_all('delete', $options);

  return $self->_rs_update_delete ('delete');
}


sub delete_all {
  my ($self, $options) = @_;
  $self->_assert_restricted_or_all('delete_all', $options);

  my $guard = $self->result_source->schema->txn_scope_guard;
  $_->delete for $self->all;
  $guard->commit;
  return 1;
}


sub populate {
  my $self = shift;

  # this is naive and just a quick check
  # the types will need to be checked more thoroughly when the
  # multi-source populate gets added
  my $data = (
    ref $_[0] eq 'ARRAY'
      and
    ( @{$_[0]} or return )
      and
    ( ref $_[0][0] eq 'HASH' or ref $_[0][0] eq 'ARRAY' )
      and
    $_[0]
  ) or $self->throw_exception('Populate expects an arrayref of hashrefs or arrayref of arrayrefs');

  # FIXME - no cref handling
  # At this point assume either hashes or arrays

  if(defined wantarray) {
    my (@results, $guard);

    if (ref $data->[0] eq 'ARRAY') {
      # column names only, nothing to do
      return if @$data == 1;

      $guard = $self->result_source->schema->storage->txn_scope_guard
        if @$data > 2;

lib/DBIO/ResultSet.pm  view on Meta::CPAN

sub find_or_new_async {
  my $self  = shift;
  my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
  my $hash  = ref $_[0] eq 'HASH' ? shift : {@_};

  return $self->_rs_run_async('find_or_new',
    sub {
      my ($backend, $fc) = @_;
      return $fc->done($self->new_result($hash)) unless keys %$hash;

      return $self->_find_for_write_async($hash, $attrs, 'find_or_new')->then(sub {
        my ($row) = @_;
        return $row if $row;
        return $self->new_result($hash);
      });
    },
    sub { $self->find_or_new($hash, $attrs) },
  );
}


sub create {
  #my ($self, $col_data) = @_;
  assert_no_internal_indirect_calls and fail_on_internal_call;
  return shift->new_result(shift)->insert;
}


sub find_or_create {
  my $self     = shift;
  my $attrs    = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
  my $hash     = ref $_[0] eq 'HASH' ? shift : {@_};
  if (keys %$hash and my $row = $self->_find_for_write($hash, $attrs, 'find_or_create') ) {
    return $row;
  }
  return $self->new_result($hash)->insert;
}


sub find_or_create_async {
  my $self  = shift;
  my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
  my $hash  = ref $_[0] eq 'HASH' ? shift : {@_};

  return $self->_rs_run_async('find_or_create',
    sub {
      my ($backend, $fc) = @_;
      return $self->create_async($hash) unless keys %$hash;

      return $self->_find_for_write_async($hash, $attrs, 'find_or_create')->then(sub {
        my ($row) = @_;
        return $row if $row;
        return $self->create_async($hash);
      });
    },
    sub { $self->find_or_create($hash, $attrs) },
  );
}


sub update_or_create {
  my $self = shift;
  my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
  my $cond = ref $_[0] eq 'HASH' ? shift : {@_};

  # find() only accepts a condition it can reduce to concrete columns on this
  # table, so the lookup drops any relation-valued key that does not resolve to
  # a concrete foreign-key condition. The FULL condition -- relation keys
  # included -- still reaches the row layer via update()/insert below, which
  # owns nested-relation semantics.
  my @lookup_cols;
  my $row = $self->_find_for_write($self->_find_lookup_cond($cond), $attrs, 'update_or_create', \@lookup_cols);
  if (defined $row) {
    $row->update($self->_update_data_for_found_row($cond, \@lookup_cols));
  }
  else {
    $row = $self->new_result($cond)->insert;
  }

  return $row;
}

# Build the find() lookup for update_or_create: the passed condition with every
# relation-valued key that does NOT reduce to a concrete foreign-key condition
# on this table removed. A resolvable belongs_to (FK-bearing hashref, or a
# blessed related object) resolves join-free to { self_fk => <defined value> }
# and stays, so find() folds it in as before. A has_many / has_one / might_have
# searched by its own non-key columns is either crosstable, or resolves join-free
# to { self_pk => undef }; leaving it in the lookup would make find() reject it
# (before the guard, it silently clobbered the key with an undef FK). Such keys
# are dropped from the LOOKUP only -- update_or_create still passes the full
# condition to the row layer, which owns nested-relation semantics. See ADR 0034.
sub _find_lookup_cond {
  my ($self, $cond) = @_;

  my $rsrc = $self->result_source;
  my %lookup = %$cond;

  for my $key (keys %lookup) {
    next unless ref $lookup{$key} eq 'HASH';
    next unless $rsrc->relationship_info($key);

    my ($rel_cond, $crosstable)
      = $self->_resolve_related_cond($rsrc, $key, $lookup{$key});

    delete $lookup{$key}
      unless $self->_related_cond_is_concrete($rel_cond, $crosstable);
  }

  return \%lookup;
}


sub update_or_create_async {
  my $self  = shift;
  my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
  my $cond  = ref $_[0] eq 'HASH' ? shift : {@_};

  return $self->_rs_run_async('update_or_create',
    sub {
      my ($backend, $fc) = @_;

      my @lookup_cols;
      return $self->_find_for_write_async($self->_find_lookup_cond($cond), $attrs, 'update_or_create', \@lookup_cols)->then(sub {
        my ($row) = @_;
        return $row->update_async($self->_update_data_for_found_row($cond, \@lookup_cols)) if defined $row;
        return $self->create_async($cond);
      });
    },
    sub { $self->update_or_create($cond, $attrs) },
  );
}


my %_upsert_options = map { $_ => 1 } qw(
  key conflict_target on_conflict update update_where result fallback relations
);

my %_upsert_result_shapes = map { $_ => 1 } qw(
  row_or_undef row_or_die count void
);

# What a single entry of the `relations` structure may say. Deliberately just
# the conflict target plus its own nesting: on_conflict, update and result are
# whole-cascade or whole-statement decisions, not per-part ones.
my %_upsert_relation_options = map { $_ => 1 } qw(
  key conflict_target relations
);


sub upsert_async {
  my ($self, $data, $opts) = @_;

  my $rsrc  = $self->result_source;
  my $sname = $rsrc->source_name || $rsrc->result_class || 'this result source';

  return $self->_rs_run_async('upsert',
    sub {
      my ($backend, $fc, $mode, @rest) = @_;

      # Cascade and fallback are each already more than one statement (a
      # transactional multi-part write, and a racy client-side read-then-write
      # respectively) -- not expressible as a single insert_async. Run
      # synchronously and resolve immediately, same precedent as
      # create_async's related-object multi-create (ADR 0031).
      if ($mode eq 'cascade') {
        return $self->_async_ctx_or_sync_punt($fc, 'upsert',
          'a cascade upsert is a transactional multi-part write',
          sub { $self->_upsert_cascade($data, $opts, $rest[0]) });
      }
      if ($mode eq 'fallback') {
        return $self->_async_ctx_or_sync_punt($fc, 'upsert',
          'the fallback upsert is a racy client-side read-then-write',
          sub { $self->_upsert_fallback($data, $opts, $rest[0]) });

lib/DBIO/ResultSet.pm  view on Meta::CPAN

# A row identified entirely by its own conflict target -- the lookup row that
# a belongs_to part almost always is, { name => 'Y' } keyed on name -- leaves
# the conflict branch with nothing to set. Flat, that is a caller mistake and
# upsert says so, pointing at on_conflict => 'nothing'. In a cascade it is not
# a choice the caller can make: DO NOTHING writes no row, and a part something
# hangs off has to be nameable. So the branch re-asserts the target instead --
# col = <the value that was attempted> -- which is a no-op on the value and
# keeps the row returned. Exactly the idiom ADR 0036 section 4 blesses for
# MySQL's identity set, for the same reason.
sub _upsert_node_opts {
  my ($self, $node, $row) = @_;

  my %opts = %{ $node->{opts} };

  return \%opts
    if exists $opts{update}
    or ( $opts{on_conflict} || 'update' ) eq 'nothing'
    or ! @{ $node->{target_cols} };

  my %rowdata = $row->get_columns;
  my %skip = map { $_ => 1 }
    @{ $node->{target_cols} }, $node->{rs}->result_source->primary_columns;

  return \%opts if grep { ! $skip{$_} } keys %rowdata;

  my @noop = grep { exists $rowdata{$_} } @{ $node->{target_cols} };
  $opts{update} = \@noop if @noop;

  return \%opts;
}

# Walk the plan: parts whose key we need first, us, then the parts that need
# ours. $prebuilt is the Row the caller of this node already had to build in
# order to set the foreign key on it.
sub _upsert_run {
  my ($self, $node, $prebuilt) = @_;

  my $rs  = $node->{rs};
  my $row = $prebuilt || $rs->new_result($node->{cols});

  $row->set_from_related(
    $_->{rel}, $self->_upsert_run($_->{node})
  ) for @{ $node->{before} };

  $row = $rs->upsert(
    { $row->get_columns }, $self->_upsert_node_opts($node, $row), $row,
  );

  for my $after (@{ $node->{after} }) {
    for my $child (@{ $after->{nodes} }) {
      my $crow = $child->{rs}->new_result($child->{cols});
      $crow->set_from_related($_, $row) for @{ $after->{revs} };
      $self->_upsert_run($child, $crow);
    }
  }

  return $row;
}


sub update_or_new {
    my $self  = shift;
    my $attrs = ( @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {} );
    my $cond  = ref $_[0] eq 'HASH' ? shift : {@_};

    my @lookup_cols;
    my $row = $self->_find_for_write( $cond, $attrs, 'update_or_new', \@lookup_cols );
    if ( defined $row ) {
        $row->update($self->_update_data_for_found_row($cond, \@lookup_cols));
        return $row;
    }

    return $self->new_result($cond);
}


sub update_or_new_async {
  my $self  = shift;
  my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
  my $cond  = ref $_[0] eq 'HASH' ? shift : {@_};

  return $self->_rs_run_async('update_or_new',
    sub {
      my ($backend, $fc) = @_;

      my @lookup_cols;
      return $self->_find_for_write_async($cond, $attrs, 'update_or_new', \@lookup_cols)->then(sub {
        my ($row) = @_;
        return $row->update_async($self->_update_data_for_found_row($cond, \@lookup_cols)) if defined $row;
        return $self->new_result($cond);
      });
    },
    sub { $self->update_or_new($cond, $attrs) },
  );
}


sub get_cache {
  shift->{all_cache};
}


sub set_cache {
  my ( $self, $data ) = @_;
  $self->throw_exception("set_cache requires an arrayref")
      if defined($data) && (ref $data ne 'ARRAY');

  # If set_cache is called after a related resultset has been created,
  # we expect subsequent calls to related_resultset to include cached
  # results (if they are present on the objects in $data).
  #
  # This won't be true if we've cached the related_resultsets already,
  # so clear them.
  $self->{related_resultsets} = {};
  $self->{all_cache} = $data;
}


sub clear_cache {
  shift->set_cache(undef);
}


sub is_paged {
  my ($self) = @_;
  return !!$self->{attrs}{page};
}


sub is_ordered {
  my ($self) = @_;
  return scalar $self->result_source->storage->_extract_order_criteria($self->{attrs}{order_by});
}


sub related_resultset {
  my ($self, $rel) = @_;