view release on metacpan or  search on metacpan

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

# (Row.pm's `update`, above).
sub _has_on_column_change_cbs {
  my $self = shift;
  return !! ( $self->_before_change || $self->_around_change || $self->_after_change );
}

# True if update()'s CascadeActions wrap would actually attempt a cascade for
# THIS row instance, once $upd (if any) has been applied -- mirrors its
# per-relationship skip condition exactly (Relationship::CascadeActions::
# update's own `next if $accessor eq 'single' && !exists
# $self->{_relationship_data}{$rel}`), rather than the coarser "does a
# cascade_update relationship exist on the source at all" question.
#
# A 'single'-accessor relationship (has_one/might_have, the cascade_update
# default) only cascades if its accessor has already been touched on this
# instance: explicitly assigned, or fetched at least once as a getter --
# either way, that's what populates _relationship_data (see
# Relationship::Codegen's 'single' accessor codegen). A freshly-loaded row
# that never touched the accessor has _relationship_data{$rel} unset, so
# CascadeActions itself would skip it -- nothing to cascade, and update_async
# must not punt over it either, or a plain one-column update on any class
# with a has_one/might_have relationship would never be truly async.
#
# $upd is checked too, and must be: set_inflated_columns (called from
# update()'s own body) populates _relationship_data for a 'single'-accessor
# key found in $upd as it processes it -- but that happens AFTER this gate
# would otherwise already have decided not to punt, since update_async calls
# this predicate before ever calling set_inflated_columns on the fast path.
# Without this check, assigning a cascade_update relationship via the update
# hashref itself (update_async({ rel => $obj })), rather than via a prior
# separate accessor call, would silently dispatch truly async and skip the
# cascade sync performs for the exact same call shape.
#
# Both checks are pure hash-key tests -- no accessor call, no I/O, no second
# invocation of set_inflated_columns -- calling the accessor itself to check
# would trigger the very query this predicate exists to let update_async
# avoid.
#
# A cascade_update relationship whose accessor attr is not 'single' (only
# possible via manual configuration; has_one/might_have always use 'single')
# is not skippable in CascadeActions's own logic, so it is always treated as
# cascading here too, matching CascadeActions's unconditional proceed for
# that case.
sub _has_cascade_update_relateds {
  my ($self, $upd) = @_;
  my $source = $self->result_source;
  my %rels = map { $_ => $source->relationship_info($_) } $source->relationships;

  for my $rel (grep { $rels{$_}{attrs}{cascade_update} } keys %rels) {
    my $accessor = $rels{$rel}{attrs}{accessor} || '';
    if ($accessor eq 'single') {
      next unless exists $self->{_relationship_data}{$rel}
        or ($upd and exists $upd->{$rel} and (!defined $upd->{$rel} or ref $upd->{$rel}));
    }
    return 1;
  }
  return 0;
}


sub update_async {
  my ($self, $upd) = @_;

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

      # ADR 0071: the hash is an assignment of the caller's
      $self->__assert_update_assignable($upd) if $upd;

      if (my $pkg = $self->_async_override_gap('update')) {
        return $self->_async_ctx_or_sync_punt($fc, 'update',
          'an override of update', sub { $self->update($upd) },
          $self->_async_override_gap_lead($pkg, 'update'));
      }

      if ($self->_has_on_column_change_cbs or $self->_has_cascade_update_relateds($upd)) {
        return $self->_async_ctx_or_sync_punt($fc, 'update',
          'an OnColumnChange callback or cascade_update relationship wraps update()',
          sub { $self->update($upd) });
      }

      # update() calls it first as well; the punts above run the full
      # update(), which calls it itself. It may take keys out of $upd.
      $self->prepare_update($upd);

      $self->{_dirty_columns} ||= {};
      delete local @{$self->{_dirty_columns}}{@{$self->_proxy_slots||[]}};

      $self->set_inflated_columns($upd) if $upd;

      my %to_update = $self->get_dirty_columns;
      return $fc->done($self) unless %to_update;

      $self->throw_exception( "Not in database" ) unless $self->in_storage;

      my $rsrc = $self->result_source;
      my $ident_cond = $self->_storage_ident_condition;

      return $backend->update_async($rsrc, \%to_update, $ident_cond)->then(sub {
        my ($rows) = @_;
        if ($rows == 0) {
          $self->throw_exception( "Can't update ${self}: row not found" );
        } elsif ($rows > 1) {
          $self->throw_exception("Can't update ${self}: updated more than one row");
        }
        $self->{_dirty_columns} = {};
        $self->{related_resultsets} = {};
        delete $self->{_column_data_in_storage};
        $self->store_storage_values if @{$self->storage_value_columns};
        return $self;
      });
    },
    sub { $self->update($upd) },
  );
}


sub update {
  my ($self, $upd) = @_;

  # ADR 0071: the hash is an assignment of the caller's
  $self->__assert_update_assignable($upd) if $upd;

  # whatever a component has to do before the columns are set and written;
  # it may take keys out of $upd
  $self->prepare_update($upd);

  # ProxyResultSetMethod (integrated helper): strip proxy slots from the
  # dirty-column set so UPDATE statements never include them. "delete
  # local" localises the deletion for the scope of this sub, so the
  # original dirty flags are restored when update returns.
  $self->{_dirty_columns} ||= {};
  delete local @{$self->{_dirty_columns}}{@{$self->_proxy_slots||[]}};

  # OnColumnChange (integrated helper): short-circuit when nothing is
  # registered. When callbacks exist, build the before/around/after
  # chain, then delegate to _update_body via around-wrapper; the whole
  # orchestration is a no-op if none of the registered columns are dirty.
  my $has_change_cbs =
       $self->_before_change
    || $self->_around_change
    || $self->_after_change;

  if ($has_change_cbs) {
    $self->set_inflated_columns($upd) if $upd;

    my %dirty = $self->get_dirty_columns
      or return $self;

    my @all_before = @{$self->_before_change || []};
    my @all_around = @{$self->_around_change || []};
    my @all_after  = @{$self->_after_change  || []};

    my @before = grep { defined $dirty{$_->{column}} } @all_before;
    my @around = grep { defined $dirty{$_->{column}} } @all_around;
    my @after  = grep { defined $dirty{$_->{column}} } @all_after;

    my $allow_override = $self->on_column_change_allow_override_args;
    my $final = $allow_override
      ? sub { $self->_update_body }
      : sub { $self->_update_body($upd) };

    for (reverse @around) {
      my $fn  = $_->{method};
      my $old = $self->get_storage_value($_->{column});
      my $new = $dirty{$_->{column}};
      my $old_final = $final;
      $final = sub { $self->$fn($old_final, $old, $new) };
    }

    my $txn_wrap = List::Util::first {
      defined $dirty{$_->{column}} && $_->{txn_wrap}
    } @all_before, @all_around, @all_after;

    my $guard;
    $guard = $self->result_source->schema->txn_scope_guard if $txn_wrap;

    for (@before) {

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

        ;
        if (my ($colname) = sort { length($a) <=> length ($b) } keys %{$prefetch->{$rel_name}[0] || {}} ) {
          $err .= sprintf ", check the inflation specification (columns/as) ending in '...%s.%s'",
          $rel_name,
          $colname,
        }

        $rsrc->throw_exception($err);
      };

      $class->throw_exception("No accessor type declared for prefetched relationship '$rel_name'")
        unless $relinfo->{attrs}{accessor};

      my $rel_rs = $new->related_resultset($rel_name);

      my @rel_objects;
      if (
        @{ $prefetch->{$rel_name} || [] }
          and
        ref($prefetch->{$rel_name}) ne $DBIO::ResultSource::RowParser::Util::null_branch_class
      ) {

        if (ref $prefetch->{$rel_name}[0] eq 'ARRAY') {
          my $rel_rsrc = $rel_rs->result_source;
          my $rel_class = $rel_rs->result_class;
          my $rel_inflator = $rel_class->can('inflate_result');
          @rel_objects = map
            { $rel_class->$rel_inflator ( $rel_rsrc, @$_ ) }
            @{$prefetch->{$rel_name}}
          ;
        }
        else {
          @rel_objects = $rel_rs->result_class->inflate_result(
            $rel_rs->result_source, @{$prefetch->{$rel_name}}
          );
        }
      }

      if ($relinfo->{attrs}{accessor} eq 'single') {
        $new->{_relationship_data}{$rel_name} = $rel_objects[0];
      }
      elsif ($relinfo->{attrs}{accessor} eq 'filter') {
        $new->{_inflated_column}{$rel_name} = $rel_objects[0];
      }

      $rel_rs->set_cache(\@rel_objects);
    }
  }

  $new->in_storage (1);

  # StorageValues (integrated helper): snapshot freshly-inflated values.
  $new->store_storage_values if @{$new->storage_value_columns};

  return $new;
}


sub insert_or_update { shift->update_or_insert(@_) }

sub update_or_insert {
  my $self = shift;
  return ($self->in_storage ? $self->update : $self->insert);
}


sub insert_or_update_async { shift->update_or_insert_async(@_) }


sub update_or_insert_async {
  my $self = shift;
  return ($self->in_storage ? $self->update_async : $self->insert_async);
}


sub is_changed {
  return keys %{shift->{_dirty_columns} || {}};
}


sub is_column_changed {
  my( $self, $col ) = @_;
  return exists $self->{_dirty_columns}->{$col};
}


sub result_source {
  $_[0]->throw_exception( 'result_source can be called on instances only' )
    unless ref $_[0];

  @_ > 1
    ? $_[0]->{_result_source} = $_[1]

    # note this is a || not a ||=, the difference is important
    : $_[0]->{_result_source} || do {
        my $class = ref $_[0];
        $_[0]->can('result_source_instance')
          ? $_[0]->result_source_instance
          : $_[0]->throw_exception(
            "No result source instance registered for $class, did you forget to call $class->table(...) ?"
          )
      }
  ;
}


sub register_column {
  my ($class, $col, $info) = @_;
  my $acc = $col;
  if (exists $info->{accessor}) {
    return unless defined $info->{accessor};
    $acc = [ $info->{accessor}, $col ];
  }
  $class->mk_group_accessors('column' => $acc);
}


sub get_from_storage {
    my $self = shift @_;
    my $attrs = shift @_;
    my $resultset = $self->result_source->resultset;

    if(defined $attrs) {
      $resultset = $resultset->search(undef, $attrs);
    }

    # ADR 0045 / karr k325: the lookup itself is synchronous and never reads
    # the pin, but the row it returns is derived from this one and keeps it --
    # and so does this row when discard_changes refreshes it from that copy.
    $resultset->{_async_context} = $self->{_async_context}