use warnings;
use base qw( DBIx::Class );
-use List::Util 'first';
+use DBIx::Class::_Util qw( bag_eq fail_on_internal_call );
use namespace::clean;
=head1 NAME
=cut
-__PACKAGE__->mk_classdata( 'position_column' => 'position' );
+__PACKAGE__->mk_classaccessor( 'position_column' => 'position' );
=head2 grouping_column
=cut
-__PACKAGE__->mk_classdata( 'grouping_column' );
+__PACKAGE__->mk_group_accessors( inherited => 'grouping_column' );
=head2 null_position_value
=cut
-__PACKAGE__->mk_classdata( 'null_position_value' => 0 );
+__PACKAGE__->mk_classaccessor( 'null_position_value' => 0 );
=head2 siblings
Returns an B<ordered> resultset of all other objects in the same
group excluding the one you called it on.
+Underneath calls L<DBIx::Class::ResultSet/search>, and therefore returns
+objects by implicitly invoking L<C<< ->all() >>|DBIx::Class::ResultSet/all>
+in list context.
+
The ordering is a backwards-compatibility artifact - if you need
-a resultset with no ordering applied use L</_siblings>
+a resultset with no ordering applied use C<_siblings>
=cut
+
sub siblings {
- my $self = shift;
- return $self->_siblings->search ({}, { order_by => $self->position_column } );
+ #my $self = shift;
+
+ DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS
+ and
+ wantarray
+ and
+ ! eval { fail_on_internal_call; 1 }
+ and
+ die "ILLEGAL LIST CONTEXT INVOCATION: $@";
+
+ # *MUST* be context sensitive due to legacy (DO NOT call search_rs)
+ $_[0]->_siblings->search ({}, { order_by => $_[0]->position_column } );
}
=head2 previous_siblings
Returns a resultset of all objects in the same group
positioned before the object on which this method was called.
+Underneath calls L<DBIx::Class::ResultSet/search>, and therefore returns
+objects by implicitly invoking L<C<< ->all() >>|DBIx::Class::ResultSet/all>
+in list context.
+
=cut
sub previous_siblings {
my $self = shift;
my $position_column = $self->position_column;
my $position = $self->get_column ($position_column);
- return ( defined $position
+
+ DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS
+ and
+ wantarray
+ and
+ ! eval { fail_on_internal_call; 1 }
+ and
+ die "ILLEGAL LIST CONTEXT INVOCATION: $@";
+
+ # *MUST* be context sensitive due to legacy (DO NOT call search_rs)
+ defined( $position )
? $self->_siblings->search ({ $position_column => { '<', $position } })
: $self->_siblings
- );
+ ;
}
=head2 next_siblings
Returns a resultset of all objects in the same group
positioned after the object on which this method was called.
+Underneath calls L<DBIx::Class::ResultSet/search>, and therefore returns
+objects by implicitly invoking L<C<< ->all() >>|DBIx::Class::ResultSet/all>
+in list context.
+
=cut
sub next_siblings {
my $self = shift;
my $position_column = $self->position_column;
my $position = $self->get_column ($position_column);
- return ( defined $position
+
+ DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS
+ and
+ wantarray
+ and
+ ! eval { fail_on_internal_call; 1 }
+ and
+ die "ILLEGAL LIST CONTEXT INVOCATION: $@";
+
+ # *MUST* be context sensitive due to legacy (DO NOT call search_rs)
+ defined( $position )
? $self->_siblings->search ({ $position_column => { '>', $position } })
: $self->_siblings
- );
+ ;
}
=head2 previous_sibling
my $self = shift;
my $position_column = $self->position_column;
- my $psib = $self->previous_siblings->search(
+ my $psib = $self->previous_siblings->search_rs(
{},
{ rows => 1, order_by => { '-desc' => $position_column } },
)->single;
- return defined $psib ? $psib : 0;
+ return defined( $psib ) ? $psib : 0;
}
=head2 first_sibling
my $self = shift;
my $position_column = $self->position_column;
- my $fsib = $self->previous_siblings->search(
+ my $fsib = $self->previous_siblings->search_rs(
{},
{ rows => 1, order_by => { '-asc' => $position_column } },
)->single;
- return defined $fsib ? $fsib : 0;
+ return defined( $fsib ) ? $fsib : 0;
}
=head2 next_sibling
sub next_sibling {
my $self = shift;
my $position_column = $self->position_column;
- my $nsib = $self->next_siblings->search(
+ my $nsib = $self->next_siblings->search_rs(
{},
{ rows => 1, order_by => { '-asc' => $position_column } },
)->single;
- return defined $nsib ? $nsib : 0;
+ return defined( $nsib ) ? $nsib : 0;
}
=head2 last_sibling
sub last_sibling {
my $self = shift;
my $position_column = $self->position_column;
- my $lsib = $self->next_siblings->search(
+ my $lsib = $self->next_siblings->search_rs(
{},
{ rows => 1, order_by => { '-desc' => $position_column } },
)->single;
- return defined $lsib ? $lsib : 0;
+ return defined( $lsib ) ? $lsib : 0;
}
-# an optimized method to get the last sibling position value without inflating a row object
+# an optimized method to get the last sibling position value without inflating a result object
sub _last_sibling_posval {
my $self = shift;
my $position_column = $self->position_column;
- my $cursor = $self->next_siblings->search(
+ my $cursor = $self->next_siblings->search_rs(
{},
{ rows => 1, order_by => { '-desc' => $position_column }, select => $position_column },
)->cursor;
- my ($pos) = $cursor->next;
- return $pos;
+ ($cursor->next)[0];
}
=head2 move_previous
my $position_column = $self->position_column;
- if ($self->is_column_changed ($position_column) ) {
+ my $rsrc = $self->result_source;
+
+ my $is_txn;
+ if ($is_txn = $rsrc->schema->storage->transaction_depth) {
+ # Reload position state from storage
+ # The thinking here is that if we are in a transaction, it is
+ # *more likely* the object went out of sync due to resultset
+ # level shenanigans. Instead of always reloading (slow) - go
+ # ahead and hand-hold only in the case of higher layers
+ # requesting the safety of a txn
+
+ $self->store_column(
+ $position_column,
+ ( $rsrc->resultset
+ ->search_rs($self->_storage_ident_condition, { rows => 1, columns => $position_column })
+ ->cursor
+ ->next
+ )[0] || $self->throw_exception(
+ sprintf "Unable to locate object '%s' in storage - object went ouf of sync...?",
+ $self->ID
+ ),
+ );
+ delete $self->{_dirty_columns}{$position_column};
+ }
+ elsif ($self->is_column_changed ($position_column) ) {
# something changed our position, we need to know where we
# used to be - use the stashed value
$self->store_column($position_column, delete $self->{_column_data_in_storage}{$position_column});
return 0;
}
- my $guard = $self->result_source->schema->txn_scope_guard;
+ my $guard = $is_txn ? undef : $rsrc->schema->txn_scope_guard;
my ($direction, @between);
if ( $from_position < $to_position ) {
my $new_pos_val = $self->_position_value ($to_position); # record this before the shift
# we need to null-position the moved row if the position column is part of a constraint
- if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $self->result_source->unique_constraints }} ) ) ) {
+ if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $rsrc->unique_constraints }} ) ) ) {
$self->_ordered_internal_update({ $position_column => $self->null_position_value });
}
$self->_shift_siblings ($direction, @between);
$self->_ordered_internal_update({ $position_column => $new_pos_val });
- $guard->commit;
+ $guard->commit if $guard;
return 1;
}
if (! keys %$changed_ordering_cols) {
return $self->next::method( undef, @_ );
}
- elsif (defined first { exists $changed_ordering_cols->{$_} } @group_columns ) {
+ elsif (grep { exists $changed_ordering_cols->{$_} } @group_columns ) {
$self->move_to_group(
# since the columns are already re-set the _grouping_clause is correct
# move_to_group() knows how to get the original storage values
# add the current position/group to the things we track old values for
sub _track_storage_value {
my ($self, $col) = @_;
- return $self->next::method($col) || defined first { $_ eq $col } ($self->position_column, $self->_grouping_columns);
+ return (
+ $self->next::method($col)
+ ||
+ grep { $_ eq $col } ($self->position_column, $self->_grouping_columns)
+ );
}
=head1 METHODS FOR EXTENDING ORDERED
=cut
-__PACKAGE__->mk_classdata( '_initial_position_value' => 1 );
+__PACKAGE__->mk_classaccessor( '_initial_position_value' => 1 );
=head2 _next_position_value
$ord = 'desc';
}
- $self->_group_rs
- ->search ({ $position_column => { -between => \@between } })
- ->update ({ $position_column => \ "$position_column $op 1" } );
+ my $shift_rs = $self->_group_rs-> search_rs ({ $position_column => { -between => \@between } });
+
+ # some databases (sqlite, pg, perhaps others) are dumb and can not do a
+ # blanket increment/decrement without violating a unique constraint.
+ # So what we do here is check if the position column is part of a unique
+ # constraint, and do a one-by-one update if this is the case.
+ my $rsrc = $self->result_source;
+
+ # set in case there are more cascades combined with $rs->update => $rs_update_all overrides
+ local $rsrc->schema->{_ORDERED_INTERNAL_UPDATE} = 1;
+ my @pcols = $rsrc->primary_columns;
+ if (
+ grep { $_ eq $position_column } ( map { @$_ } (values %{{ $rsrc->unique_constraints }} ) )
+ ) {
+ my $clean_rs = $rsrc->resultset;
+
+ for ( $shift_rs->search_rs (
+ {}, { order_by => { "-$ord", $position_column }, select => [$position_column, @pcols] }
+ )->cursor->all ) {
+ my $pos = shift @$_;
+ $clean_rs->find(@$_)->update ({ $position_column => $pos + ( ($op eq '+') ? 1 : -1 ) });
+ }
+ }
+ else {
+ $shift_rs->update ({ $position_column => \ "$position_column $op 1" } );
+ }
}
# This method returns a resultset containing all members of the row
# group (including the row itself).
sub _group_rs {
- my $self = shift;
- return $self->result_source->resultset->search({$self->_grouping_clause()});
+ #my $self = shift;
+
+ DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS
+ and
+ wantarray
+ and
+ ! eval { fail_on_internal_call; 1 }
+ and
+ die "ILLEGAL LIST CONTEXT INVOCATION: $@";
+
+ # *MUST* be context sensitive due to legacy (DO NOT call search_rs)
+ $_[0]->result_source->resultset->search({ $_[0]->_grouping_clause() });
}
# Returns an unordered resultset of all objects in the same group
my $self = shift;
my $position_column = $self->position_column;
my $pos;
- return defined ($pos = $self->get_column($position_column))
+
+ DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS
+ and
+ wantarray
+ and
+ ! eval { fail_on_internal_call; 1 }
+ and
+ die "ILLEGAL LIST CONTEXT INVOCATION: $@";
+
+ # *MUST* be context sensitive due to legacy (DO NOT call search_rs)
+ defined( $pos = $self->get_column($position_column) )
? $self->_group_rs->search(
{ $position_column => { '!=' => $pos } },
)
my ($self, $other) = @_;
my $current = {$self->_grouping_clause};
- no warnings qw/uninitialized/;
-
- return 0 if (
- join ("\x00", sort keys %$current)
- ne
- join ("\x00", sort keys %$other)
- );
- for my $key (keys %$current) {
- return 0 if $current->{$key} ne $other->{$key};
- }
- return 1;
+ (
+ bag_eq(
+ [ keys %$current ],
+ [ keys %$other ],
+ )
+ and
+ ! grep {
+ (
+ defined( $current->{$_} )
+ xor
+ defined( $other->{$_} )
+ )
+ or
+ (
+ defined $current->{$_}
+ and
+ $current->{$_} ne $other->{$_}
+ )
+ } keys %$other
+ ) ? 1 : 0;
}
# This is a short-circuited method, that is used internally by this
# you are doing use this method which bypasses any hooks introduced by
# this module.
sub _ordered_internal_update {
- my $self = shift;
- local $self->result_source->schema->{_ORDERED_INTERNAL_UPDATE} = 1;
- return $self->update (@_);
+ local $_[0]->result_source->schema->{_ORDERED_INTERNAL_UPDATE} = 1;
+ shift->update (@_);
}
1;
=head2 Multiple Moves
-Be careful when issuing move_* methods to multiple objects. If
-you've pre-loaded the objects then when you move one of the objects
-the position of the other object will not reflect their new value
-until you reload them from the database - see
-L<DBIx::Class::Row/discard_changes>.
+If you have multiple same-group result objects already loaded from storage,
+you need to be careful when executing C<move_*> operations on them:
+without a L</position_column> reload the L</_position_value> of the
+"siblings" will be out of sync with the underlying storage.
+
+Starting from version C<0.082800> DBIC will implicitly perform such
+reloads when the C<move_*> happens as a part of a transaction
+(a good example of such situation is C<< $ordered_resultset->delete_all >>).
-There are times when you will want to move objects as groups, such
-as changing the parent of several objects at once - this directly
-conflicts with this problem. One solution is for us to write a
-ResultSet class that supports a parent() method, for example. Another
-solution is to somehow automagically modify the objects that exist
-in the current object's result set to have the new position value.
+If it is not possible for you to wrap the entire call-chain in a transaction,
+you will need to call L<DBIx::Class::Row/discard_changes> to get an object
+up-to-date before proceeding, otherwise undefined behavior will result.
=head2 Default Values
Using a database defined default_value on one of your group columns
could result in the position not being assigned correctly.
-=head1 AUTHOR
-
- Original code framework
- Aran Deltac <bluefeet@cpan.org>
-
- Constraints support and code generalisation
- Peter Rabbitson <ribasushi@cpan.org>
+=head1 FURTHER QUESTIONS?
-=head1 LICENSE
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-You may distribute this code under the same terms as Perl itself.
+=head1 COPYRIGHT AND LICENSE
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.