X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FOrdered.pm;h=2ac0a0781ca353528fb361e867e2ec90c965c9b2;hb=7474ed3b192693baa28d2f52de502f0ec3e8ac4e;hp=88e1110ea32896bec0e92ec93fc96f3df7d0df61;hpb=90545b68b06c2d2d288d593462539fe45fff48a6;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Ordered.pm b/lib/DBIx/Class/Ordered.pm index 88e1110..2ac0a07 100644 --- a/lib/DBIx/Class/Ordered.pm +++ b/lib/DBIx/Class/Ordered.pm @@ -1,9 +1,11 @@ -# 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. @@ -18,35 +20,63 @@ Create a table for your ordered data. position 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'); +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(); @@ -59,13 +89,13 @@ That's it, now you can change the position of your objects. =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 @@ -74,134 +104,231 @@ move a record it always causes other records in the list to be updated. __PACKAGE__->position_column('position'); -Sets and retrieves the name of the column that stores the +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 specifies 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 which B 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 resultset or an array of all other objects -excluding the one you called it on. +Returns an B resultset of all other objects in the same +group excluding the one you called it on. + +Underneath calls L, and therefore returns +objects by implicitly invoking Lall() >>|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 sibling. +Returns a resultset of all objects in the same group +positioned before the object on which this method was called. -=cut +Underneath calls L, and therefore returns +objects by implicitly invoking Lall() >>|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(); -Returns 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, and therefore returns +objects by implicitly invoking Lall() >>|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. Returns undef +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 forward. Returns undef +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 $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 $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 $cursor = $self->next_siblings->search( + {}, + { rows => 1, order_by => { '-desc' => $position_column }, select => $position_column }, + )->cursor; + + ($cursor->next)[0]; } =head2 move_previous @@ -215,9 +342,8 @@ 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 @@ -231,11 +357,9 @@ 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 @@ -248,8 +372,7 @@ 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 @@ -262,9 +385,12 @@ 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 @@ -279,27 +405,72 @@ position. 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 @@ -310,7 +481,7 @@ group, or to the end of the group if $position is undef. 1 is returned on success, and 0 is returned if the object is already at the specified position of the specified group. -$group may be specified as a single scalar if only one +$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. @@ -319,50 +490,73 @@ if multiple grouping columns are in use. 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 @@ -370,8 +564,17 @@ the table +1, thus positioning the new record at the last position. 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( @_ ); } @@ -386,82 +589,280 @@ of a new group if it has been changed to undef. =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( @_ ); - # if any of our grouping columns have been changed - 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 of an object with a B 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 of L of the object at numeric +position C<$pos>. By default simply returns C<$pos>. -This method returns a name=>value pair for limiting a search -by the collection column. If the collection 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 of L 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 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 that would be considered C 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 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 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 returns () -if there is no grouping. +Note that if you override this method and have unique constraints +including the L 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 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(); @@ -474,68 +875,108 @@ sub _grouping_columns { } } - - -=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 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 methods only. If you use the +L versions of +L or +L, all logic present in this +module will be bypassed entirely (possibly resulting in a broken +order-tree). Instead always use the +L and +L methods, which will +invoke the corresponding L 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, and 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 or +L, 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) +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 operations on them: +without a L reload the L 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 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 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 +=head1 FURTHER QUESTIONS? -=head1 LICENSE +Check the list of L. -You may distribute this code under the same terms as Perl itself. +=head1 COPYRIGHT AND LICENSE +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L.