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) = @_;
  $self->throw_exception('Values for update must be a hash')
    unless ref $values eq 'HASH';

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


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

  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 = shift;
  $self->throw_exception('delete does not accept any arguments')
    if @_;

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


sub delete_all {
  my $self = shift;
  $self->throw_exception('delete_all does not accept any arguments')
    if @_;

  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

  my ($self, $query, $alias) = @_;

  my %orig = %{ $query || {} };
  my %unaliased;

  foreach my $key (keys %orig) {
    if ($key !~ /\./) {
      $unaliased{$key} = $orig{$key};
      next;
    }
    $unaliased{$1} = $orig{$key}
      if $key =~ m/^(?:\Q$alias\E\.)?([^.]+)$/;
  }

  return \%unaliased;
}


sub as_query {
  my $self = shift;

  my $attrs = { %{ $self->_resolved_attrs } };

  my $aq = $self->result_source->storage->_select_args_to_query (
    $attrs->{from}, $attrs->{select}, $attrs->{where}, $attrs
  );

  $aq;
}


sub find_or_new {
  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($hash, $attrs) ) {
    return $row;
  }
  return $self->new_result($hash);
}


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($hash, $attrs) ) {
    return $row;
  }
  return $self->new_result($hash)->insert;
}


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

  my ($main_cond, $related_subconds) = $self->_split_related_update_conds($cond);

  # When related sub-structures are peeled off to be applied after the main
  # row, wrap the whole operation in a transaction so a partially-built graph
  # never survives a failure -- mirroring the multi-create guarantee in
  # DBIO::Row::insert. No transaction is opened for the common no-relation case.
  my $guard = keys %$related_subconds
    ? $self->result_source->schema->txn_scope_guard
    : undef;

  my $row = $self->find($main_cond, $attrs);
  if (defined $row) {
    $row->update($main_cond);
  }
  else {
    $row = $self->new_result($main_cond)->insert;
  }

  # DWIM: apply each peeled-off relation through the (now stored) main row's
  # related resultset. The main-table 'key' constraint applies only to the main
  # table, so it is intentionally NOT propagated to these calls.
  for my $rel_name (keys %$related_subconds) {
    $row->related_resultset($rel_name)
        ->update_or_create($related_subconds->{$rel_name});
  }

  $guard->commit if $guard;

  return $row;
}

# update_or_create() DWIM: split a mixed condition into ( \%main_cond,
# \%related_subconds ). A top-level key is peeled off into %related_subconds
# only when it is a relationship name whose value is a plain (unblessed) hashref
# that does NOT reduce to a *concrete* foreign-key condition on the main table.
#
# A resolvable belongs_to (FK-bearing hashref, or a blessed related object)
# reduces join-free to { self_fk => <defined value> } and STAYS in %main_cond --
# find()/update() handle it exactly as before. A has_many / has_one / might_have
# searched by its own non-key columns either is crosstable, or resolves join-free
# to { self_pk => undef } (which would silently clobber the main key with an
# undef FK -- the original defect this DWIM fixes). Those are peeled off and
# applied to their own related resultset after the main row exists.
#
# has_many arrayrefs (multi) and blessed/other non-plain-hashref relation values
# are left untouched in %main_cond: the main create/multi-create or update path
# already handles or rejects them, unchanged. See ADR 0033.
sub _split_related_update_conds {
  my ($self, $cond) = @_;

  my $rsrc = $self->result_source;
  my %main_cond = %$cond;
  my %related_subconds;

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

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

    # Keep in the main search only when the relation reduces to a concrete,
    # fully-defined foreign-key condition on this table (resolvable belongs_to).
    my $concrete_fk =
         ! $crosstable
      && ref $rel_cond eq 'HASH'
      && keys %$rel_cond
      && ! grep {
           ! defined $_ or ( ! ref($_) && $_ eq UNRESOLVABLE_CONDITION )
         } values %$rel_cond;

    next if $concrete_fk;

    $related_subconds{$key} = delete $main_cond{$key};
  }

  return (\%main_cond, \%related_subconds);
}


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

    my $row = $self->find( $cond, $attrs );
    if ( defined $row ) {
        $row->update($cond);
        return $row;
    }

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


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) = @_;

  return $self->{related_resultsets}{$rel}
    if defined $self->{related_resultsets}{$rel};

  return $self->{related_resultsets}{$rel} = do {
    my $rsrc = $self->result_source;