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;
585 if (not defined wantarray) {
586 $self->next::method( @_ );
589 @res = $self->next::method( @_ );
592 $res[0] = $self->next::method( @_ );
596 return wantarray ? @res : $res[0];
599 # add the current position/group to the things we track old values for
600 sub _track_storage_value {
601 my ($self, $col) = @_;
602 return $self->next::method($col) || defined first { $_ eq $col } ($self->position_column, $self->_grouping_columns);
605 =head1 METHODS FOR EXTENDING ORDERED
607 You would want to override the methods below if you use sparse
608 (non-linear) or non-numeric position values. This can be useful
609 if you are working with preexisting non-normalised position data,
610 or if you need to work with materialized path columns.
612 =head2 _position_from_value
614 my $num_pos = $item->_position_from_value ( $pos_value )
616 Returns the B<absolute numeric position> of an object with a B<position
617 value> set to C<$pos_value>. By default simply returns C<$pos_value>.
620 sub _position_from_value {
621 my ($self, $val) = @_;
623 return 0 unless defined $val;
625 # #the right way to do this
626 # return $self -> _group_rs
627 # -> search({ $self->position_column => { '<=', $val } })
633 =head2 _position_value
635 my $pos_value = $item->_position_value ( $pos )
637 Returns the B<value> of L</position_column> of the object at numeric
638 position C<$pos>. By default simply returns C<$pos>.
641 sub _position_value {
642 my ($self, $pos) = @_;
644 # #the right way to do this (not optimized)
645 # my $position_column = $self->position_column;
646 # return $self -> _group_rs
647 # -> search({}, { order_by => $position_column })
648 # -> slice ( $pos - 1)
650 # -> get_column ($position_column);
655 =head2 _initial_position_value
657 __PACKAGE__->_initial_position_value(0);
659 This method specifies a B<value> of L</position_column> which is assigned
660 to the first inserted element of a group, if no value was supplied at
661 insertion time. All subsequent values are derived from this one by
662 L</_next_position_value> below. Defaults to 1.
666 __PACKAGE__->mk_classdata( '_initial_position_value' => 1 );
668 =head2 _next_position_value
670 my $new_value = $item->_next_position_value ( $position_value )
672 Returns a position B<value> that would be considered C<next> with
673 regards to C<$position_value>. Can be pretty much anything, given
674 that C<< $position_value < $new_value >> where C<< < >> is the
675 SQL comparison operator (usually works fine on strings). The
676 default method expects C<$position_value> to be numeric, and
677 returns C<$position_value + 1>
680 sub _next_position_value {
684 =head2 _shift_siblings
686 $item->_shift_siblings ($direction, @between)
688 Shifts all siblings with B<positions values> in the range @between
689 (inclusive) by one position as specified by $direction (left if < 0,
690 right if > 0). By default simply increments/decrements each
691 L</position_column> value by 1, doing so in a way as to not violate
692 any existing constraints.
694 Note that if you override this method and have unique constraints
695 including the L</position_column> the shift is not a trivial task.
696 Refer to the implementation source of the default method for more
700 sub _shift_siblings {
701 my ($self, $direction, @between) = @_;
702 return 0 unless $direction;
704 my $position_column = $self->position_column;
707 if ($direction < 0) {
716 my $shift_rs = $self->_group_rs-> search ({ $position_column => { -between => \@between } });
718 # some databases (sqlite) are dumb and can not do a blanket
719 # increment/decrement. So what we do here is check if the
720 # position column is part of a unique constraint, and do a
721 # one-by-one update if this is the case
722 # Also we do a one-by-one if the position is part of the PK
723 # since once we update a column via scalarref we lose the
724 # ability to retrieve this column back (we do not know the
727 my $rsrc = $self->result_source;
729 # set in case there are more cascades combined with $rs->update => $rs_update_all overrides
730 local $rsrc->schema->{_ORDERED_INTERNAL_UPDATE} = 1;
731 my @pcols = $rsrc->primary_columns;
732 my $pos_is_pk = first { $_ eq $position_column } @pcols;
736 first { $_ eq $position_column } ( map { @$_ } (values %{{ $rsrc->unique_constraints }} ) )
738 my $cursor = $shift_rs->search (
739 {}, { order_by => { "-$ord", $position_column }, select => [$position_column, @pcols] }
741 my $rs = $self->result_source->resultset;
743 my @all_data = $cursor->all;
744 while (my $data = shift @all_data) {
745 my $pos = shift @$data;
747 for my $i (0.. $#pcols) {
748 $cond->{$pcols[$i]} = $data->[$i];
751 $rs->find($cond)->update ({ $position_column => $pos + ( ($op eq '+') ? 1 : -1 ) });
755 $shift_rs->update ({ $position_column => \ "$position_column $op 1" } );
759 =head1 PRIVATE METHODS
761 These methods are used internally. You should never have the
766 This method returns a resultset containing all members of the row
767 group (including the row itself).
772 return $self->result_source->resultset->search({$self->_grouping_clause()});
777 Returns an unordered resultset of all objects in the same group
778 excluding the object you called this method on.
783 my $position_column = $self->position_column;
785 return defined ($pos = $self->get_column($position_column))
786 ? $self->_group_rs->search(
787 { $position_column => { '!=' => $pos } },
795 my $num_pos = $item->_position;
797 Returns the B<absolute numeric position> of the current object, with the
798 first object being at position 1, its sibling at position 2 and so on.
803 return $self->_position_from_value ($self->get_column ($self->position_column) );
806 =head2 _grouping_clause
808 This method returns one or more name=>value pairs for limiting a search
809 by the grouping column(s). If the grouping column is not defined then
810 this will return an empty list.
813 sub _grouping_clause {
815 return map { $_ => $self->get_column($_) } $self->_grouping_columns();
818 =head2 _get_grouping_columns
820 Returns a list of the column names used for grouping, regardless of whether
821 they were specified as an arrayref or a single string, and returns ()
822 if there is no grouping.
825 sub _grouping_columns {
827 my $col = $self->grouping_column();
828 if (ref $col eq 'ARRAY') {
839 $item->_is_in_group( {user => 'fred', list => 'work'} )
841 Returns true if the object is in the group represented by hashref $other
845 my ($self, $other) = @_;
846 my $current = {$self->_grouping_clause};
848 no warnings qw/uninitialized/;
851 join ("\x00", sort keys %$current)
853 join ("\x00", sort keys %$other)
855 for my $key (keys %$current) {
856 return 0 if $current->{$key} ne $other->{$key};
861 =head2 _ordered_internal_update
863 This is a short-circuited method, that is used internally by this
864 module to update positioning values in isolation (i.e. without
865 triggering any of the positioning integrity code).
867 Some day you might get confronted by datasets that have ambiguous
868 positioning data (e.g. duplicate position values within the same group,
869 in a table without unique constraints). When manually fixing such data
870 keep in mind that you can not invoke L<DBIx::Class::Row/update> like
871 you normally would, as it will get confused by the wrong data before
872 having a chance to update the ill-defined row. If you really know what
873 you are doing use this method which bypasses any hooks introduced by
878 sub _ordered_internal_update {
880 local $self->result_source->schema->{_ORDERED_INTERNAL_UPDATE} = 1;
881 return $self->update (@_);
890 =head2 Resultset Methods
892 Note that all Insert/Create/Delete overrides are happening on
893 L<DBIx::Class::Row> methods only. If you use the
894 L<DBIx::Class::ResultSet> versions of
895 L<update|DBIx::Class::ResultSet/update> or
896 L<delete|DBIx::Class::ResultSet/delete>, all logic present in this
897 module will be bypassed entirely (possibly resulting in a broken
898 order-tree). Instead always use the
899 L<update_all|DBIx::Class::ResultSet/update_all> and
900 L<delete_all|DBIx::Class::ResultSet/delete_all> methods, which will
901 invoke the corresponding L<row|DBIx::Class::Row> method on every
902 member of the given resultset.
904 =head2 Race Condition on Insert
906 If a position is not specified for an insert, a position
907 will be chosen based either on L</_initial_position_value> or
908 L</_next_position_value>, depending if there are already some
909 items in the current group. The space of time between the
910 necessary selects and insert introduces a race condition.
911 Having unique constraints on your position/group columns,
912 and using transactions (see L<DBIx::Class::Storage/txn_do>)
913 will prevent such race conditions going undetected.
915 =head2 Multiple Moves
917 Be careful when issuing move_* methods to multiple objects. If
918 you've pre-loaded the objects then when you move one of the objects
919 the position of the other object will not reflect their new value
920 until you reload them from the database - see
921 L<DBIx::Class::Row/discard_changes>.
923 There are times when you will want to move objects as groups, such
924 as changing the parent of several objects at once - this directly
925 conflicts with this problem. One solution is for us to write a
926 ResultSet class that supports a parent() method, for example. Another
927 solution is to somehow automagically modify the objects that exist
928 in the current object's result set to have the new position value.
930 =head2 Default Values
932 Using a database defined default_value on one of your group columns
933 could result in the position not being assigned correctly.
937 Original code framework
938 Aran Deltac <bluefeet@cpan.org>
940 Constraints support and code generalisation
941 Peter Rabbitson <ribasushi@cpan.org>
945 You may distribute this code under the same terms as Perl itself.