1 package DBIx::Class::Ordered;
4 use base qw( DBIx::Class );
6 use List::Util 'first';
11 DBIx::Class::Ordered - Modify the position of objects in an ordered list.
15 Create a table for your ordered data.
18 item_id INTEGER PRIMARY KEY AUTOINCREMENT,
20 position INTEGER NOT NULL
23 Optionally, add one or more columns to specify groupings, allowing you
24 to maintain independent ordered lists within one table:
27 item_id INTEGER PRIMARY KEY AUTOINCREMENT,
29 position INTEGER NOT NULL,
30 group_id INTEGER NOT NULL
36 item_id INTEGER PRIMARY KEY AUTOINCREMENT,
38 position INTEGER NOT NULL,
39 group_id INTEGER NOT NULL,
40 other_group_id INTEGER NOT NULL
43 In your Schema or DB class add "Ordered" to the top
44 of the component list.
46 __PACKAGE__->load_components(qw( Ordered ... ));
48 Specify the column that stores the position number for
52 __PACKAGE__->position_column('position');
54 If you are using one grouping column, specify it as follows:
56 __PACKAGE__->grouping_column('group_id');
58 Or if you have multiple grouping columns:
60 __PACKAGE__->grouping_column(['group_id', 'other_group_id']);
62 That's it, now you can change the position of your objects.
67 my $item = My::Item->create({ name=>'Matt S. Trout' });
68 # If using grouping_column:
69 my $item = My::Item->create({ name=>'Matt S. Trout', group_id=>1 });
71 my $rs = $item->siblings();
72 my @siblings = $item->siblings();
75 $sibling = $item->first_sibling();
76 $sibling = $item->last_sibling();
77 $sibling = $item->previous_sibling();
78 $sibling = $item->next_sibling();
80 $item->move_previous();
84 $item->move_to( $position );
85 $item->move_to_group( 'groupname' );
86 $item->move_to_group( 'groupname', $position );
87 $item->move_to_group( {group_id=>'groupname', 'other_group_id=>'othergroupname'} );
88 $item->move_to_group( {group_id=>'groupname', 'other_group_id=>'othergroupname'}, $position );
92 This module provides a simple interface for modifying the ordered
93 position of DBIx::Class objects.
97 All of the move_* methods automatically update the rows involved in
98 the query. This is not configurable and is due to the fact that if you
99 move a record it always causes other records in the list to be updated.
103 =head2 position_column
105 __PACKAGE__->position_column('position');
107 Sets and retrieves the name of the column that stores the
108 positional value of each record. Defaults to "position".
112 __PACKAGE__->mk_classdata( 'position_column' => 'position' );
114 =head2 grouping_column
116 __PACKAGE__->grouping_column('group_id');
118 This method specifies a column to limit all queries in
119 this module by. This effectively allows you to have multiple
120 ordered lists within the same table.
124 __PACKAGE__->mk_classdata( 'grouping_column' );
126 =head2 null_position_value
128 __PACKAGE__->null_position_value(undef);
130 This method specifies a value of L</position_column> which B<would
131 never be assigned to a row> during normal operation. When
132 a row is moved, its position is set to this value temporarily, so
133 that any unique constraints can not be violated. This value defaults
134 to 0, which should work for all cases except when your positions do
139 __PACKAGE__->mk_classdata( 'null_position_value' => 0 );
143 my $rs = $item->siblings();
144 my @siblings = $item->siblings();
146 Returns an B<ordered> resultset of all other objects in the same
147 group excluding the one you called it on.
149 The ordering is a backwards-compatibility artifact - if you need
150 a resultset with no ordering applied use L</_siblings>
155 return $self->_siblings->search ({}, { order_by => $self->position_column } );
158 =head2 previous_siblings
160 my $prev_rs = $item->previous_siblings();
161 my @prev_siblings = $item->previous_siblings();
163 Returns a resultset of all objects in the same group
164 positioned before the object on which this method was called.
167 sub previous_siblings {
169 my $position_column = $self->position_column;
170 my $position = $self->get_column ($position_column);
171 return ( defined $position
172 ? $self->_siblings->search ({ $position_column => { '<', $position } })
179 my $next_rs = $item->next_siblings();
180 my @next_siblings = $item->next_siblings();
182 Returns a resultset of all objects in the same group
183 positioned after the object on which this method was called.
188 my $position_column = $self->position_column;
189 my $position = $self->get_column ($position_column);
190 return ( defined $position
191 ? $self->_siblings->search ({ $position_column => { '>', $position } })
196 =head2 previous_sibling
198 my $sibling = $item->previous_sibling();
200 Returns the sibling that resides one position back. Returns 0
201 if the current object is the first one.
205 sub previous_sibling {
207 my $position_column = $self->position_column;
209 my $psib = $self->previous_siblings->search(
211 { rows => 1, order_by => { '-desc' => $position_column } },
214 return defined $psib ? $psib : 0;
219 my $sibling = $item->first_sibling();
221 Returns the first sibling object, or 0 if the first sibling
228 my $position_column = $self->position_column;
230 my $fsib = $self->previous_siblings->search(
232 { rows => 1, order_by => { '-asc' => $position_column } },
235 return defined $fsib ? $fsib : 0;
240 my $sibling = $item->next_sibling();
242 Returns the sibling that resides one position forward. Returns 0
243 if the current object is the last one.
249 my $position_column = $self->position_column;
250 my $nsib = $self->next_siblings->search(
252 { rows => 1, order_by => { '-asc' => $position_column } },
255 return defined $nsib ? $nsib : 0;
260 my $sibling = $item->last_sibling();
262 Returns the last sibling, or 0 if the last sibling is this
269 my $position_column = $self->position_column;
270 my $lsib = $self->next_siblings->search(
272 { rows => 1, order_by => { '-desc' => $position_column } },
275 return defined $lsib ? $lsib : 0;
278 # an optimized method to get the last sibling position value without inflating a row object
279 sub _last_sibling_posval {
281 my $position_column = $self->position_column;
283 my $cursor = $self->next_siblings->search(
285 { rows => 1, order_by => { '-desc' => $position_column }, select => $position_column },
288 my ($pos) = $cursor->next;
294 $item->move_previous();
296 Swaps position with the sibling in the position previous in
297 the list. Returns 1 on success, and 0 if the object is
298 already the first one.
304 return $self->move_to ($self->_position - 1);
311 Swaps position with the sibling in the next position in the
312 list. Returns 1 on success, and 0 if the object is already
313 the last in the list.
319 return 0 unless defined $self->_last_sibling_posval; # quick way to check for no more siblings
320 return $self->move_to ($self->_position + 1);
327 Moves the object to the first position in the list. Returns 1
328 on success, and 0 if the object is already the first.
333 return shift->move_to( 1 );
340 Moves the object to the last position in the list. Returns 1
341 on success, and 0 if the object is already the last one.
347 my $last_posval = $self->_last_sibling_posval;
349 return 0 unless defined $last_posval;
351 return $self->move_to( $self->_position_from_value ($last_posval) );
356 $item->move_to( $position );
358 Moves the object to the specified position. Returns 1 on
359 success, and 0 if the object is already at the specified
365 my( $self, $to_position ) = @_;
366 return 0 if ( $to_position < 1 );
368 my $position_column = $self->position_column;
370 if ($self->is_column_changed ($position_column) ) {
371 # something changed our position, we need to know where we
372 # used to be - use the stashed value
373 $self->store_column($position_column, delete $self->{_column_data_in_storage}{$position_column});
374 delete $self->{_dirty_columns}{$position_column};
377 my $from_position = $self->_position;
379 if ( $from_position == $to_position ) { # FIXME this will not work for non-numeric order
383 my $guard = $self->result_source->schema->txn_scope_guard;
385 my ($direction, @between);
386 if ( $from_position < $to_position ) {
388 @between = map { $self->_position_value ($_) } ( $from_position + 1, $to_position );
392 @between = map { $self->_position_value ($_) } ( $to_position, $from_position - 1 );
395 my $new_pos_val = $self->_position_value ($to_position); # record this before the shift
397 # we need to null-position the moved row if the position column is part of a constraint
398 if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $self->result_source->unique_constraints }} ) ) ) {
399 $self->_ordered_internal_update({ $position_column => $self->null_position_value });
402 $self->_shift_siblings ($direction, @between);
403 $self->_ordered_internal_update({ $position_column => $new_pos_val });
411 $item->move_to_group( $group, $position );
413 Moves the object to the specified position of the specified
414 group, or to the end of the group if $position is undef.
415 1 is returned on success, and 0 is returned if the object is
416 already at the specified position of the specified group.
418 $group may be specified as a single scalar if only one
419 grouping column is in use, or as a hashref of column => value pairs
420 if multiple grouping columns are in use.
425 my( $self, $to_group, $to_position ) = @_;
427 # if we're given a single value, turn it into a hashref
428 unless (ref $to_group eq 'HASH') {
429 my @gcols = $self->_grouping_columns;
431 $self->throw_exception ('Single group supplied for a multi-column group identifier') if @gcols > 1;
432 $to_group = {$gcols[0] => $to_group};
435 my $position_column = $self->position_column;
437 return 0 if ( defined($to_position) and $to_position < 1 );
439 # check if someone changed the _grouping_columns - this will
440 # prevent _is_in_group working, so we need to restore the
441 # original stashed values
442 for ($self->_grouping_columns) {
443 if ($self->is_column_changed ($_)) {
444 $self->store_column($_, delete $self->{_column_data_in_storage}{$_});
445 delete $self->{_dirty_columns}{$_};
449 if ($self->_is_in_group ($to_group) ) {
451 if (defined $to_position) {
452 $ret = $self->move_to ($to_position);
458 my $guard = $self->result_source->schema->txn_scope_guard;
460 # Move to end of current group to adjust siblings
463 $self->set_inflated_columns({ %$to_group, $position_column => undef });
464 my $new_group_last_posval = $self->_last_sibling_posval;
465 my $new_group_last_position = $self->_position_from_value (
466 $new_group_last_posval
469 if ( not defined($to_position) or $to_position > $new_group_last_position) {
471 $position_column => $new_group_last_position
472 ? $self->_next_position_value ( $new_group_last_posval )
473 : $self->_initial_position_value
477 my $bumped_pos_val = $self->_position_value ($to_position);
478 my @between = map { $self->_position_value ($_) } ($to_position, $new_group_last_position);
479 $self->_shift_siblings (1, @between); #shift right
480 $self->set_column( $position_column => $bumped_pos_val );
483 $self->_ordered_internal_update;
492 Overrides the DBIC insert() method by providing a default
493 position number. The default will be the number of rows in
494 the table +1, thus positioning the new record at the last position.
500 my $position_column = $self->position_column;
502 unless ($self->get_column($position_column)) {
503 my $lsib_posval = $self->_last_sibling_posval;
505 $position_column => (defined $lsib_posval
506 ? $self->_next_position_value ( $lsib_posval )
507 : $self->_initial_position_value
512 return $self->next::method( @_ );
517 Overrides the DBIC update() method by checking for a change
518 to the position and/or group columns. Movement within a
519 group or to another group is handled by repositioning
520 the appropriate siblings. Position defaults to the end
521 of a new group if it has been changed to undef.
528 # this is set by _ordered_internal_update()
529 return $self->next::method(@_) if $self->result_source->schema->{_ORDERED_INTERNAL_UPDATE};
532 $self->set_inflated_columns($upd) if $upd;
534 my $position_column = $self->position_column;
535 my @group_columns = $self->_grouping_columns;
537 # see if the order is already changed
538 my $changed_ordering_cols = { map { $_ => $self->get_column($_) } grep { $self->is_column_changed($_) } ($position_column, @group_columns) };
540 # nothing changed - short circuit
541 if (! keys %$changed_ordering_cols) {
542 return $self->next::method( undef, @_ );
544 elsif (defined first { exists $changed_ordering_cols->{$_} } @group_columns ) {
545 $self->move_to_group(
546 # since the columns are already re-set the _grouping_clause is correct
547 # move_to_group() knows how to get the original storage values
548 { $self->_grouping_clause },
550 # The FIXME bit contradicts the documentation: POD states that
551 # when changing groups without supplying explicit positions in
552 # move_to_group(), we push the item to the end of the group.
553 # However when I was rewriting this, the position from the old
554 # group was clearly passed to the new one
555 # Probably needs to go away (by ribasushi)
556 (exists $changed_ordering_cols->{$position_column}
557 ? $changed_ordering_cols->{$position_column} # means there was a position change supplied with the update too
558 : $self->_position # FIXME! (replace with undef)
563 $self->move_to($changed_ordering_cols->{$position_column});
571 Overrides the DBIC delete() method by first moving the object
572 to the last position, then deleting it, thus ensuring the
573 integrity of the positions.
580 my $guard = $self->result_source->schema->txn_scope_guard;
584 $self->next::method( @_ );
591 # add the current position/group to the things we track old values for
592 sub _track_storage_value {
593 my ($self, $col) = @_;
594 return $self->next::method($col) || defined first { $_ eq $col } ($self->position_column, $self->_grouping_columns);
597 =head1 METHODS FOR EXTENDING ORDERED
599 You would want to override the methods below if you use sparse
600 (non-linear) or non-numeric position values. This can be useful
601 if you are working with preexisting non-normalised position data,
602 or if you need to work with materialized path columns.
604 =head2 _position_from_value
606 my $num_pos = $item->_position_from_value ( $pos_value )
608 Returns the B<absolute numeric position> of an object with a B<position
609 value> set to C<$pos_value>. By default simply returns C<$pos_value>.
612 sub _position_from_value {
613 my ($self, $val) = @_;
615 return 0 unless defined $val;
617 # #the right way to do this
618 # return $self -> _group_rs
619 # -> search({ $self->position_column => { '<=', $val } })
625 =head2 _position_value
627 my $pos_value = $item->_position_value ( $pos )
629 Returns the B<value> of L</position_column> of the object at numeric
630 position C<$pos>. By default simply returns C<$pos>.
633 sub _position_value {
634 my ($self, $pos) = @_;
636 # #the right way to do this (not optimized)
637 # my $position_column = $self->position_column;
638 # return $self -> _group_rs
639 # -> search({}, { order_by => $position_column })
640 # -> slice ( $pos - 1)
642 # -> get_column ($position_column);
647 =head2 _initial_position_value
649 __PACKAGE__->_initial_position_value(0);
651 This method specifies a B<value> of L</position_column> which is assigned
652 to the first inserted element of a group, if no value was supplied at
653 insertion time. All subsequent values are derived from this one by
654 L</_next_position_value> below. Defaults to 1.
658 __PACKAGE__->mk_classdata( '_initial_position_value' => 1 );
660 =head2 _next_position_value
662 my $new_value = $item->_next_position_value ( $position_value )
664 Returns a position B<value> that would be considered C<next> with
665 regards to C<$position_value>. Can be pretty much anything, given
666 that C<< $position_value < $new_value >> where C<< < >> is the
667 SQL comparison operator (usually works fine on strings). The
668 default method expects C<$position_value> to be numeric, and
669 returns C<$position_value + 1>
672 sub _next_position_value {
676 =head2 _shift_siblings
678 $item->_shift_siblings ($direction, @between)
680 Shifts all siblings with B<positions values> in the range @between
681 (inclusive) by one position as specified by $direction (left if < 0,
682 right if > 0). By default simply increments/decrements each
683 L</position_column> value by 1, doing so in a way as to not violate
684 any existing constraints.
686 Note that if you override this method and have unique constraints
687 including the L</position_column> the shift is not a trivial task.
688 Refer to the implementation source of the default method for more
692 sub _shift_siblings {
693 my ($self, $direction, @between) = @_;
694 return 0 unless $direction;
696 my $position_column = $self->position_column;
699 if ($direction < 0) {
709 ->search ({ $position_column => { -between => \@between } })
710 ->update ({ $position_column => \ "$position_column $op 1" } );
714 # This method returns a resultset containing all members of the row
715 # group (including the row itself).
718 return $self->result_source->resultset->search({$self->_grouping_clause()});
721 # Returns an unordered resultset of all objects in the same group
722 # excluding the object you called this method on.
725 my $position_column = $self->position_column;
727 return defined ($pos = $self->get_column($position_column))
728 ? $self->_group_rs->search(
729 { $position_column => { '!=' => $pos } },
735 # Returns the B<absolute numeric position> of the current object, with the
736 # first object being at position 1, its sibling at position 2 and so on.
739 return $self->_position_from_value ($self->get_column ($self->position_column) );
742 # This method returns one or more name=>value pairs for limiting a search
743 # by the grouping column(s). If the grouping column is not defined then
744 # this will return an empty list.
745 sub _grouping_clause {
747 return map { $_ => $self->get_column($_) } $self->_grouping_columns();
750 # Returns a list of the column names used for grouping, regardless of whether
751 # they were specified as an arrayref or a single string, and returns ()
752 # if there is no grouping.
753 sub _grouping_columns {
755 my $col = $self->grouping_column();
756 if (ref $col eq 'ARRAY') {
765 # Returns true if the object is in the group represented by hashref $other
767 my ($self, $other) = @_;
768 my $current = {$self->_grouping_clause};
770 no warnings qw/uninitialized/;
773 join ("\x00", sort keys %$current)
775 join ("\x00", sort keys %$other)
777 for my $key (keys %$current) {
778 return 0 if $current->{$key} ne $other->{$key};
783 # This is a short-circuited method, that is used internally by this
784 # module to update positioning values in isolation (i.e. without
785 # triggering any of the positioning integrity code).
787 # Some day you might get confronted by datasets that have ambiguous
788 # positioning data (e.g. duplicate position values within the same group,
789 # in a table without unique constraints). When manually fixing such data
790 # keep in mind that you can not invoke L<DBIx::Class::Row/update> like
791 # you normally would, as it will get confused by the wrong data before
792 # having a chance to update the ill-defined row. If you really know what
793 # you are doing use this method which bypasses any hooks introduced by
795 sub _ordered_internal_update {
797 local $self->result_source->schema->{_ORDERED_INTERNAL_UPDATE} = 1;
798 return $self->update (@_);
807 =head2 Resultset Methods
809 Note that all Insert/Create/Delete overrides are happening on
810 L<DBIx::Class::Row> methods only. If you use the
811 L<DBIx::Class::ResultSet> versions of
812 L<update|DBIx::Class::ResultSet/update> or
813 L<delete|DBIx::Class::ResultSet/delete>, all logic present in this
814 module will be bypassed entirely (possibly resulting in a broken
815 order-tree). Instead always use the
816 L<update_all|DBIx::Class::ResultSet/update_all> and
817 L<delete_all|DBIx::Class::ResultSet/delete_all> methods, which will
818 invoke the corresponding L<row|DBIx::Class::Row> method on every
819 member of the given resultset.
821 =head2 Race Condition on Insert
823 If a position is not specified for an insert, a position
824 will be chosen based either on L</_initial_position_value> or
825 L</_next_position_value>, depending if there are already some
826 items in the current group. The space of time between the
827 necessary selects and insert introduces a race condition.
828 Having unique constraints on your position/group columns,
829 and using transactions (see L<DBIx::Class::Storage/txn_do>)
830 will prevent such race conditions going undetected.
832 =head2 Multiple Moves
834 Be careful when issuing move_* methods to multiple objects. If
835 you've pre-loaded the objects then when you move one of the objects
836 the position of the other object will not reflect their new value
837 until you reload them from the database - see
838 L<DBIx::Class::Row/discard_changes>.
840 There are times when you will want to move objects as groups, such
841 as changing the parent of several objects at once - this directly
842 conflicts with this problem. One solution is for us to write a
843 ResultSet class that supports a parent() method, for example. Another
844 solution is to somehow automagically modify the objects that exist
845 in the current object's result set to have the new position value.
847 =head2 Default Values
849 Using a database defined default_value on one of your group columns
850 could result in the position not being assigned correctly.
854 Original code framework
855 Aran Deltac <bluefeet@cpan.org>
857 Constraints support and code generalisation
858 Peter Rabbitson <ribasushi@cpan.org>
862 You may distribute this code under the same terms as Perl itself.