-# vim: ts=8:sw=4:sts=4:et
package DBIx::Class::Ordered;
use strict;
use warnings;
use base qw( DBIx::Class );
+use DBIx::Class::_Util qw( bag_eq fail_on_internal_call );
+use namespace::clean;
+
=head1 NAME
DBIx::Class::Ordered - Modify the position of objects in an ordered list.
name TEXT NOT NULL,
position INTEGER NOT NULL
);
- # Optional: group_id INTEGER NOT NULL
-In your Schema or DB class add Ordered to the top
+Optionally, add one or more columns to specify groupings, allowing you
+to maintain independent ordered lists within one table:
+
+ CREATE TABLE items (
+ item_id INTEGER PRIMARY KEY AUTOINCREMENT,
+ name TEXT NOT NULL,
+ position INTEGER NOT NULL,
+ group_id INTEGER NOT NULL
+ );
+
+Or even
+
+ CREATE TABLE items (
+ item_id INTEGER PRIMARY KEY AUTOINCREMENT,
+ name TEXT NOT NULL,
+ position INTEGER NOT NULL,
+ group_id INTEGER NOT NULL,
+ other_group_id INTEGER NOT NULL
+ );
+
+In your Schema or DB class add "Ordered" to the top
of the component list.
__PACKAGE__->load_components(qw( Ordered ... ));
-Specify the column that stores the position number for
+Specify the column that stores the position number for
each row.
package My::Item;
__PACKAGE__->position_column('position');
- __PACKAGE__->grouping_column('group_id'); # optional
-Thats it, now you can change the position of your objects.
+If you are using one grouping column, specify it as follows:
+
+ __PACKAGE__->grouping_column('group_id');
+
+Or if you have multiple grouping columns:
+
+ __PACKAGE__->grouping_column(['group_id', 'other_group_id']);
+
+That's it, now you can change the position of your objects.
#!/use/bin/perl
use My::Item;
-
+
my $item = My::Item->create({ name=>'Matt S. Trout' });
# If using grouping_column:
my $item = My::Item->create({ name=>'Matt S. Trout', group_id=>1 });
-
+
my $rs = $item->siblings();
my @siblings = $item->siblings();
-
+
my $sibling;
$sibling = $item->first_sibling();
$sibling = $item->last_sibling();
$sibling = $item->previous_sibling();
$sibling = $item->next_sibling();
-
+
$item->move_previous();
$item->move_next();
$item->move_first();
$item->move_last();
$item->move_to( $position );
+ $item->move_to_group( 'groupname' );
+ $item->move_to_group( 'groupname', $position );
+ $item->move_to_group( {group_id=>'groupname', 'other_group_id=>'othergroupname'} );
+ $item->move_to_group( {group_id=>'groupname', 'other_group_id=>'othergroupname'}, $position );
=head1 DESCRIPTION
-This module provides a simple interface for modifying the ordered
+This module provides a simple interface for modifying the ordered
position of DBIx::Class objects.
=head1 AUTO UPDATE
-All of the move_* methods automatically update the rows involved in
-the query. This is not configurable and is due to the fact that if you
+All of the move_* methods automatically update the rows involved in
+the query. This is not configurable and is due to the fact that if you
move a record it always causes other records in the list to be updated.
=head1 METHODS
__PACKAGE__->position_column('position');
-Sets and retrieves the name of the column that stores the
-positional value of each record. Default to "position".
+Sets and retrieves the name of the column that stores the
+positional value of each record. Defaults to "position".
=cut
-__PACKAGE__->mk_classdata( 'position_column' => 'position' );
+__PACKAGE__->mk_classaccessor( 'position_column' => 'position' );
=head2 grouping_column
__PACKAGE__->grouping_column('group_id');
-This method specified a column to limit all queries in
-this module by. This effectively allows you to have multiple
+This method specifies a column to limit all queries in
+this module by. This effectively allows you to have multiple
ordered lists within the same table.
=cut
-__PACKAGE__->mk_classdata( 'grouping_column' );
+__PACKAGE__->mk_group_accessors( inherited => 'grouping_column' );
+
+=head2 null_position_value
+
+ __PACKAGE__->null_position_value(undef);
+
+This method specifies a value of L</position_column> which B<would
+never be assigned to a row> during normal operation. When
+a row is moved, its position is set to this value temporarily, so
+that any unique constraints can not be violated. This value defaults
+to 0, which should work for all cases except when your positions do
+indeed start from 0.
+
+=cut
+
+__PACKAGE__->mk_classaccessor( 'null_position_value' => 0 );
=head2 siblings
my $rs = $item->siblings();
my @siblings = $item->siblings();
-Returns either a result set or an array of all other objects
-excluding the one you called it on.
+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 C<_siblings>
=cut
sub siblings {
- my( $self ) = @_;
- my $position_column = $self->position_column;
- my $rs = $self->result_source->resultset->search(
- {
- $position_column => { '!=' => $self->get_column($position_column) },
- $self->_grouping_clause(),
- },
- { order_by => $self->position_column },
- );
- return $rs->all() if (wantarray());
- return $rs;
+ #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 first_sibling
+=head2 previous_siblings
- my $sibling = $item->first_sibling();
+ my $prev_rs = $item->previous_siblings();
+ my @prev_siblings = $item->previous_siblings();
-Returns the first sibling object, or 0 if the first sibling
-is this sibliing.
+Returns a resultset of all objects in the same group
+positioned before the object on which this method was called.
-=cut
+Underneath calls L<DBIx::Class::ResultSet/search>, and therefore returns
+objects by implicitly invoking L<C<< ->all() >>|DBIx::Class::ResultSet/all>
+in list context.
-sub first_sibling {
- my( $self ) = @_;
- return 0 if ($self->get_column($self->position_column())==1);
-
- return ($self->result_source->resultset->search(
- {
- $self->position_column => 1,
- $self->_grouping_clause(),
- },
- )->all())[0];
+=cut
+sub previous_siblings {
+ my $self = shift;
+ my $position_column = $self->position_column;
+ my $position = $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( $position )
+ ? $self->_siblings->search ({ $position_column => { '<', $position } })
+ : $self->_siblings
+ ;
}
-=head2 last_sibling
+=head2 next_siblings
- my $sibling = $item->last_sibling();
+ my $next_rs = $item->next_siblings();
+ my @next_siblings = $item->next_siblings();
-Return the last sibling, or 0 if the last sibling is this
-sibling.
+Returns a resultset of all objects in the same group
+positioned after the object on which this method was called.
-=cut
+Underneath calls L<DBIx::Class::ResultSet/search>, and therefore returns
+objects by implicitly invoking L<C<< ->all() >>|DBIx::Class::ResultSet/all>
+in list context.
-sub last_sibling {
- my( $self ) = @_;
- my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
- return 0 if ($self->get_column($self->position_column())==$count);
- return ($self->result_source->resultset->search(
- {
- $self->position_column => $count,
- $self->_grouping_clause(),
- },
- )->all())[0];
+=cut
+sub next_siblings {
+ my $self = shift;
+ my $position_column = $self->position_column;
+ my $position = $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( $position )
+ ? $self->_siblings->search ({ $position_column => { '>', $position } })
+ : $self->_siblings
+ ;
}
=head2 previous_sibling
my $sibling = $item->previous_sibling();
-Returns the sibling that resides one position back. Undef
-is returned if the current object is the first one.
+Returns the sibling that resides one position back. Returns 0
+if the current object is the first one.
=cut
sub previous_sibling {
- my( $self ) = @_;
+ my $self = shift;
my $position_column = $self->position_column;
- my $position = $self->get_column( $position_column );
- return 0 if ($position==1);
- return ($self->result_source->resultset->search(
- {
- $position_column => $position - 1,
- $self->_grouping_clause(),
- }
- )->all())[0];
+
+ my $psib = $self->previous_siblings->search(
+ {},
+ { rows => 1, order_by => { '-desc' => $position_column } },
+ )->single;
+
+ return defined( $psib ) ? $psib : 0;
+}
+
+=head2 first_sibling
+
+ my $sibling = $item->first_sibling();
+
+Returns the first sibling object, or 0 if the first sibling
+is this sibling.
+
+=cut
+
+sub first_sibling {
+ my $self = shift;
+ my $position_column = $self->position_column;
+
+ my $fsib = $self->previous_siblings->search(
+ {},
+ { rows => 1, order_by => { '-asc' => $position_column } },
+ )->single;
+
+ return defined( $fsib ) ? $fsib : 0;
}
=head2 next_sibling
my $sibling = $item->next_sibling();
-Returns the sibling that resides one position foward. Undef
-is returned if the current object is the last one.
+Returns the sibling that resides one position forward. Returns 0
+if the current object is the last one.
=cut
sub next_sibling {
- my( $self ) = @_;
+ my $self = shift;
+ my $position_column = $self->position_column;
+ my $nsib = $self->next_siblings->search(
+ {},
+ { rows => 1, order_by => { '-asc' => $position_column } },
+ )->single;
+
+ return defined( $nsib ) ? $nsib : 0;
+}
+
+=head2 last_sibling
+
+ my $sibling = $item->last_sibling();
+
+Returns the last sibling, or 0 if the last sibling is this
+sibling.
+
+=cut
+
+sub last_sibling {
+ my $self = shift;
my $position_column = $self->position_column;
- my $position = $self->get_column( $position_column );
- my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
- return 0 if ($position==$count);
- return ($self->result_source->resultset->search(
- {
- $position_column => $position + 1,
- $self->_grouping_clause(),
- },
- )->all())[0];
+ my $lsib = $self->next_siblings->search(
+ {},
+ { rows => 1, order_by => { '-desc' => $position_column } },
+ )->single;
+
+ return defined( $lsib ) ? $lsib : 0;
+}
+
+# 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(
+ {},
+ { rows => 1, order_by => { '-desc' => $position_column }, select => $position_column },
+ )->cursor;
+
+ ($cursor->next)[0];
}
=head2 move_previous
$item->move_previous();
-Swaps position with the sibling on position previous in the list.
-1 is returned on success, and 0 is returned if the objects is already
-the first one.
+Swaps position with the sibling in the position previous in
+the list. Returns 1 on success, and 0 if the object is
+already the first one.
=cut
sub move_previous {
- my( $self ) = @_;
- my $position = $self->get_column( $self->position_column() );
- return $self->move_to( $position - 1 );
+ my $self = shift;
+ return $self->move_to ($self->_position - 1);
}
=head2 move_next
$item->move_next();
-Swaps position with the sibling in the next position. 1 is returned on
-success, and 0 is returned if the object is already the last in the list.
+Swaps position with the sibling in the next position in the
+list. Returns 1 on success, and 0 if the object is already
+the last in the list.
=cut
sub move_next {
- my( $self ) = @_;
- my $position = $self->get_column( $self->position_column() );
- my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
- return 0 if ($position==$count);
- return $self->move_to( $position + 1 );
+ my $self = shift;
+ return 0 unless defined $self->_last_sibling_posval; # quick way to check for no more siblings
+ return $self->move_to ($self->_position + 1);
}
=head2 move_first
$item->move_first();
-Moves the object to the first position. 1 is returned on
-success, and 0 is returned if the object is already the first.
+Moves the object to the first position in the list. Returns 1
+on success, and 0 if the object is already the first.
=cut
sub move_first {
- my( $self ) = @_;
- return $self->move_to( 1 );
+ return shift->move_to( 1 );
}
=head2 move_last
$item->move_last();
-Moves the object to the very last position. 1 is returned on
-success, and 0 is returned if the object is already the last one.
+Moves the object to the last position in the list. Returns 1
+on success, and 0 if the object is already the last one.
=cut
sub move_last {
- my( $self ) = @_;
- my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
- return $self->move_to( $count );
+ my $self = shift;
+ my $last_posval = $self->_last_sibling_posval;
+
+ return 0 unless defined $last_posval;
+
+ return $self->move_to( $self->_position_from_value ($last_posval) );
}
=head2 move_to
$item->move_to( $position );
-Moves the object to the specified position. 1 is returned on
-success, and 0 is returned if the object is already at the
-specified position.
+Moves the object to the specified position. Returns 1 on
+success, and 0 if the object is already at the specified
+position.
=cut
sub move_to {
my( $self, $to_position ) = @_;
- my $position_column = $self->position_column;
- my $from_position = $self->get_column( $position_column );
return 0 if ( $to_position < 1 );
- return 0 if ( $from_position==$to_position );
- my @between = (
- ( $from_position < $to_position )
- ? ( $from_position+1, $to_position )
- : ( $to_position, $from_position-1 )
- );
- my $rs = $self->result_source->resultset->search({
- $position_column => { -between => [ @between ] },
- $self->_grouping_clause(),
- });
- my $op = ($from_position>$to_position) ? '+' : '-';
- $rs->update({ $position_column => \"$position_column $op 1" }); #" Sorry, GEdit bug
- $self->{_ORDERED_INTERNAL_UPDATE} = 1;
- $self->update({ $position_column => $to_position });
- return 1;
-}
+ my $position_column = $self->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($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});
+ delete $self->{_dirty_columns}{$position_column};
+ }
+
+ my $from_position = $self->_position;
+
+ if ( $from_position == $to_position ) { # FIXME this will not work for non-numeric order
+ return 0;
+ }
+
+ my $guard = $is_txn ? undef : $rsrc->schema->txn_scope_guard;
+ my ($direction, @between);
+ if ( $from_position < $to_position ) {
+ $direction = -1;
+ @between = map { $self->_position_value ($_) } ( $from_position + 1, $to_position );
+ }
+ else {
+ $direction = 1;
+ @between = map { $self->_position_value ($_) } ( $to_position, $from_position - 1 );
+ }
+
+ 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 %{{ $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 if $guard;
+ return 1;
+}
=head2 move_to_group
1 is returned on success, and 0 is returned if the object is
already at the specified position of the specified group.
-$group should be supplied as a hashref of column => value pairs,
-e.g. if the grouping columns were 'user' and 'list',
-{ user => 'fred', list => 'work' }.
+$group may be specified as a single scalar if only one
+grouping column is in use, or as a hashref of column => value pairs
+if multiple grouping columns are in use.
=cut
sub move_to_group {
my( $self, $to_group, $to_position ) = @_;
- # if we're given a string, turn it into a hashref
+ # if we're given a single value, turn it into a hashref
unless (ref $to_group eq 'HASH') {
- $to_group = {($self->_grouping_columns)[0] => $to_group};
+ my @gcols = $self->_grouping_columns;
+
+ $self->throw_exception ('Single group supplied for a multi-column group identifier') if @gcols > 1;
+ $to_group = {$gcols[0] => $to_group};
}
my $position_column = $self->position_column;
- #my @grouping_columns = $self->_grouping_columns;
- return 0 if ( ! defined($to_group) );
return 0 if ( defined($to_position) and $to_position < 1 );
- return 0 if ( $self->_is_in_group($to_group)
- and ((not defined($to_position))
- or (defined($to_position) and $self->$position_column==$to_position)
- )
- );
- # Move to end of current group and adjust siblings
+ # check if someone changed the _grouping_columns - this will
+ # prevent _is_in_group working, so we need to restore the
+ # original stashed values
+ for ($self->_grouping_columns) {
+ if ($self->is_column_changed ($_)) {
+ $self->store_column($_, delete $self->{_column_data_in_storage}{$_});
+ delete $self->{_dirty_columns}{$_};
+ }
+ }
+
+ if ($self->_is_in_group ($to_group) ) {
+ my $ret;
+ if (defined $to_position) {
+ $ret = $self->move_to ($to_position);
+ }
+
+ return $ret||0;
+ }
+
+ my $guard = $self->result_source->schema->txn_scope_guard;
+
+ # Move to end of current group to adjust siblings
$self->move_last;
- $self->set_columns($to_group);
- my $new_group_count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
- if (!defined($to_position) or $to_position > $new_group_count) {
- $self->{_ORDERED_INTERNAL_UPDATE} = 1;
- $self->update({ $position_column => $new_group_count + 1 });
+ $self->set_inflated_columns({ %$to_group, $position_column => undef });
+ my $new_group_last_posval = $self->_last_sibling_posval;
+ my $new_group_last_position = $self->_position_from_value (
+ $new_group_last_posval
+ );
+
+ if ( not defined($to_position) or $to_position > $new_group_last_position) {
+ $self->set_column(
+ $position_column => $new_group_last_position
+ ? $self->_next_position_value ( $new_group_last_posval )
+ : $self->_initial_position_value
+ );
}
else {
- my @between = ($to_position, $new_group_count);
-
- my $rs = $self->result_source->resultset->search({
- $position_column => { -between => [ @between ] },
- $self->_grouping_clause(),
- });
- $rs->update({ $position_column => \"$position_column + 1" }); #"
- $self->{_ORDERED_INTERNAL_UPDATE} = 1;
- $self->update({ $position_column => $to_position });
+ my $bumped_pos_val = $self->_position_value ($to_position);
+ my @between = map { $self->_position_value ($_) } ($to_position, $new_group_last_position);
+ $self->_shift_siblings (1, @between); #shift right
+ $self->set_column( $position_column => $bumped_pos_val );
}
+ $self->_ordered_internal_update;
+
+ $guard->commit;
+
return 1;
}
=head2 insert
-Overrides the DBIC insert() method by providing a default
-position number. The default will be the number of rows in
+Overrides the DBIC insert() method by providing a default
+position number. The default will be the number of rows in
the table +1, thus positioning the new record at the last position.
=cut
sub insert {
my $self = shift;
my $position_column = $self->position_column;
- $self->set_column( $position_column => $self->result_source->resultset->search( {$self->_grouping_clause()} )->count()+1 )
- if (!$self->get_column($position_column));
+
+ unless ($self->get_column($position_column)) {
+ my $lsib_posval = $self->_last_sibling_posval;
+ $self->set_column(
+ $position_column => (defined $lsib_posval
+ ? $self->_next_position_value ( $lsib_posval )
+ : $self->_initial_position_value
+ )
+ );
+ }
+
return $self->next::method( @_ );
}
=cut
sub update {
+ my $self = shift;
+
+ # this is set by _ordered_internal_update()
+ return $self->next::method(@_) if $self->result_source->schema->{_ORDERED_INTERNAL_UPDATE};
+
+ my $upd = shift;
+ $self->set_inflated_columns($upd) if $upd;
+
+ my $position_column = $self->position_column;
+ my @group_columns = $self->_grouping_columns;
+
+ # see if the order is already changed
+ my $changed_ordering_cols = { map { $_ => $self->get_column($_) } grep { $self->is_column_changed($_) } ($position_column, @group_columns) };
+
+ # nothing changed - short circuit
+ if (! keys %$changed_ordering_cols) {
+ return $self->next::method( undef, @_ );
+ }
+ 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
+ { $self->_grouping_clause },
+
+ # The FIXME bit contradicts the documentation: POD states that
+ # when changing groups without supplying explicit positions in
+ # move_to_group(), we push the item to the end of the group.
+ # However when I was rewriting this, the position from the old
+ # group was clearly passed to the new one
+ # Probably needs to go away (by ribasushi)
+ (exists $changed_ordering_cols->{$position_column}
+ ? $changed_ordering_cols->{$position_column} # means there was a position change supplied with the update too
+ : $self->_position # FIXME! (replace with undef)
+ ),
+ );
+ }
+ else {
+ $self->move_to($changed_ordering_cols->{$position_column});
+ }
+
+ return $self;
+}
+
+=head2 delete
+
+Overrides the DBIC delete() method by first moving the object
+to the last position, then deleting it, thus ensuring the
+integrity of the positions.
+
+=cut
+
+sub delete {
my $self = shift;
- if ($self->{_ORDERED_INTERNAL_UPDATE}) {
- delete $self->{_ORDERED_INTERNAL_UPDATE};
- return $self->next::method( @_ );
- }
+ my $guard = $self->result_source->schema->txn_scope_guard;
- $self->set_columns($_[0]) if @_ > 0;
- my %changes = $self->get_dirty_columns;
- $self->discard_changes;
+ $self->move_last;
- my $pos_col = $self->position_column;
+ $self->next::method( @_ );
- # is there a chance in hell of this working?
- # if any of our grouping columns have been changed
-$DB::single=1;
- if (grep {$_} map {exists $changes{$_}} $self->_grouping_columns ) {
+ $guard->commit;
- # create new_group by taking the current group and inserting changes
- my $new_group = {$self->_grouping_clause};
- foreach my $col (keys %$new_group) {
- if (exists $changes{$col}) {
- $new_group->{$col} = $changes{$col};
- delete $changes{$col}; # don't want to pass this on to next::method
- }
- }
+ return $self;
+}
- $self->move_to_group(
- $new_group,
- exists($changes{$pos_col}) ? delete($changes{$pos_col}) : $self->$pos_col
- );
- }
- elsif (exists $changes{$pos_col}) {
- $self->move_to(delete $changes{$pos_col});
- }
- return $self->next::method( \%changes );
+# 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)
+ ||
+ grep { $_ eq $col } ($self->position_column, $self->_grouping_columns)
+ );
}
-=head2 delete
+=head1 METHODS FOR EXTENDING ORDERED
-Overrides the DBIC delete() method by first moving the object
-to the last position, then deleting it, thus ensuring the
-integrity of the positions.
+You would want to override the methods below if you use sparse
+(non-linear) or non-numeric position values. This can be useful
+if you are working with preexisting non-normalised position data,
+or if you need to work with materialized path columns.
+
+=head2 _position_from_value
+
+ my $num_pos = $item->_position_from_value ( $pos_value )
+
+Returns the B<absolute numeric position> of an object with a B<position
+value> set to C<$pos_value>. By default simply returns C<$pos_value>.
=cut
+sub _position_from_value {
+ my ($self, $val) = @_;
-sub delete {
- my $self = shift;
- $self->move_last;
- return $self->next::method( @_ );
+ return 0 unless defined $val;
+
+# #the right way to do this
+# return $self -> _group_rs
+# -> search({ $self->position_column => { '<=', $val } })
+# -> count
+
+ return $val;
}
-=head1 PRIVATE METHODS
+=head2 _position_value
-These methods are used internally. You should never have the
-need to use them.
+ my $pos_value = $item->_position_value ( $pos )
-=head2 _grouping_clause
+Returns the B<value> of L</position_column> of the object at numeric
+position C<$pos>. By default simply returns C<$pos>.
-This method returns one or more name=>value pairs for limiting a search
-by the grouping column(s). If the grouping column is not
-defined then this will return an empty list.
+=cut
+sub _position_value {
+ my ($self, $pos) = @_;
+
+# #the right way to do this (not optimized)
+# my $position_column = $self->position_column;
+# return $self -> _group_rs
+# -> search({}, { order_by => $position_column })
+# -> slice ( $pos - 1)
+# -> single
+# -> get_column ($position_column);
+
+ return $pos;
+}
+
+=head2 _initial_position_value
+
+ __PACKAGE__->_initial_position_value(0);
+
+This method specifies a B<value> of L</position_column> which is assigned
+to the first inserted element of a group, if no value was supplied at
+insertion time. All subsequent values are derived from this one by
+L</_next_position_value> below. Defaults to 1.
=cut
-sub _grouping_clause {
- my( $self ) = @_;
- return map { $_ => $self->get_column($_) } $self->_grouping_columns();
+
+__PACKAGE__->mk_classaccessor( '_initial_position_value' => 1 );
+
+=head2 _next_position_value
+
+ my $new_value = $item->_next_position_value ( $position_value )
+
+Returns a position B<value> that would be considered C<next> with
+regards to C<$position_value>. Can be pretty much anything, given
+that C<< $position_value < $new_value >> where C<< < >> is the
+SQL comparison operator (usually works fine on strings). The
+default method expects C<$position_value> to be numeric, and
+returns C<$position_value + 1>
+
+=cut
+sub _next_position_value {
+ return $_[1] + 1;
}
+=head2 _shift_siblings
+ $item->_shift_siblings ($direction, @between)
-=head2 _get_grouping_columns
+Shifts all siblings with B<positions values> in the range @between
+(inclusive) by one position as specified by $direction (left if < 0,
+ right if > 0). By default simply increments/decrements each
+L</position_column> value by 1, doing so in a way as to not violate
+any existing constraints.
-Returns a list of the column names used for grouping, regardless of whether
-they were specified as an arrayref or a single string, and even returns ()
-if we're not grouping.
+Note that if you override this method and have unique constraints
+including the L</position_column> the shift is not a trivial task.
+Refer to the implementation source of the default method for more
+information.
=cut
+sub _shift_siblings {
+ my ($self, $direction, @between) = @_;
+ return 0 unless $direction;
+
+ my $position_column = $self->position_column;
+
+ my ($op, $ord);
+ if ($direction < 0) {
+ $op = '-';
+ $ord = 'asc';
+ }
+ else {
+ $op = '+';
+ $ord = 'desc';
+ }
+
+ my $shift_rs = $self->_group_rs-> search ({ $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 (
+ {}, { 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;
+
+ 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
+# excluding the object you called this method on.
+sub _siblings {
+ my $self = shift;
+ my $position_column = $self->position_column;
+ my $pos;
+
+ 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 } },
+ )
+ : $self->_group_rs
+ ;
+}
+
+# Returns the B<absolute numeric position> of the current object, with the
+# first object being at position 1, its sibling at position 2 and so on.
+sub _position {
+ my $self = shift;
+ return $self->_position_from_value ($self->get_column ($self->position_column) );
+}
+
+# This method returns one or more name=>value pairs for limiting a search
+# by the grouping column(s). If the grouping column is not defined then
+# this will return an empty list.
+sub _grouping_clause {
+ my( $self ) = @_;
+ return map { $_ => $self->get_column($_) } $self->_grouping_columns();
+}
+
+# Returns a list of the column names used for grouping, regardless of whether
+# they were specified as an arrayref or a single string, and returns ()
+# if there is no grouping.
sub _grouping_columns {
my( $self ) = @_;
my $col = $self->grouping_column();
}
}
-
-
-=head2 _is_in_group($other)
-
- $item->_is_in_group( {user => 'fred', list => 'work'} )
-
-Returns true if the object is in the group represented by hashref $other
-=cut
+# Returns true if the object is in the group represented by hashref $other
sub _is_in_group {
my ($self, $other) = @_;
my $current = {$self->_grouping_clause};
- return 0 unless (ref $other eq 'HASH') and (keys %$current == keys %$other);
- for my $key (keys %$current) {
- return 0 unless exists $other->{$key};
- 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
+# module to update positioning values in isolation (i.e. without
+# triggering any of the positioning integrity code).
+#
+# Some day you might get confronted by datasets that have ambiguous
+# positioning data (e.g. duplicate position values within the same group,
+# in a table without unique constraints). When manually fixing such data
+# keep in mind that you can not invoke L<DBIx::Class::Row/update> like
+# you normally would, as it will get confused by the wrong data before
+# having a chance to update the ill-defined row. If you really know what
+# you are doing use this method which bypasses any hooks introduced by
+# this module.
+sub _ordered_internal_update {
+ local $_[0]->result_source->schema->{_ORDERED_INTERNAL_UPDATE} = 1;
+ shift->update (@_);
+}
1;
+
__END__
-=head1 BUGS
+=head1 CAVEATS
-=head2 Unique Constraints
+=head2 Resultset Methods
-Unique indexes and constraints on the position column are not
-supported at this time. It would be make sense to support them,
-but there are some unexpected database issues that make this
-hard to do. The main problem from the author's view is that
-SQLite (the DB engine that we use for testing) does not support
-ORDER BY on updates.
+Note that all Insert/Create/Delete overrides are happening on
+L<DBIx::Class::Row> methods only. If you use the
+L<DBIx::Class::ResultSet> versions of
+L<update|DBIx::Class::ResultSet/update> or
+L<delete|DBIx::Class::ResultSet/delete>, all logic present in this
+module will be bypassed entirely (possibly resulting in a broken
+order-tree). Instead always use the
+L<update_all|DBIx::Class::ResultSet/update_all> and
+L<delete_all|DBIx::Class::ResultSet/delete_all> methods, which will
+invoke the corresponding L<row|DBIx::Class::Row> method on every
+member of the given resultset.
=head2 Race Condition on Insert
-If a position is not specified for an insert than a position
-will be chosen based on COUNT(*)+1. But, it first selects the
-count then inserts the record. The space of time between select
-and insert introduces a race condition. To fix this we need the
-ability to lock tables in DBIC. I've added an entry in the TODO
-about this.
+If a position is not specified for an insert, a position
+will be chosen based either on L</_initial_position_value> or
+L</_next_position_value>, depending if there are already some
+items in the current group. The space of time between the
+necessary selects and insert introduces a race condition.
+Having unique constraints on your position/group columns,
+and using transactions (see L<DBIx::Class::Storage/txn_do>)
+will prevent such race conditions going undetected.
=head2 Multiple Moves
-Be careful when issueing 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.
+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 >>).
+
+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.
-There are times when you will want to move objects as groups, such
-as changeing 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.
+=head2 Default Values
-=head1 AUTHOR
+Using a database defined default_value on one of your group columns
+could result in the position not being assigned correctly.
-Aran Deltac <bluefeet@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>.
projects / dbsrgits/DBIx-Class.git / blobdiff