1 package DBIx::Class::Ordered;
4 use base qw( DBIx::Class );
6 use DBIx::Class::_Util qw( bag_eq fail_on_internal_call );
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_classaccessor( '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_group_accessors( inherited => '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_classaccessor( '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 Underneath calls L<DBIx::Class::ResultSet/search>, and therefore returns
150 objects by implicitly invoking L<C<< ->all() >>|DBIx::Class::ResultSet/all>
153 The ordering is a backwards-compatibility artifact - if you need
154 a resultset with no ordering applied use C<_siblings>
161 DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS
165 ! eval { fail_on_internal_call; 1 }
167 die "ILLEGAL LIST CONTEXT INVOCATION: $@";
169 # *MUST* be context sensitive due to legacy (DO NOT call search_rs)
170 $_[0]->_siblings->search ({}, { order_by => $_[0]->position_column } );
173 =head2 previous_siblings
175 my $prev_rs = $item->previous_siblings();
176 my @prev_siblings = $item->previous_siblings();
178 Returns a resultset of all objects in the same group
179 positioned before the object on which this method was called.
181 Underneath calls L<DBIx::Class::ResultSet/search>, and therefore returns
182 objects by implicitly invoking L<C<< ->all() >>|DBIx::Class::ResultSet/all>
186 sub previous_siblings {
188 my $position_column = $self->position_column;
189 my $position = $self->get_column ($position_column);
191 DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS
195 ! eval { fail_on_internal_call; 1 }
197 die "ILLEGAL LIST CONTEXT INVOCATION: $@";
199 # *MUST* be context sensitive due to legacy (DO NOT call search_rs)
201 ? $self->_siblings->search ({ $position_column => { '<', $position } })
208 my $next_rs = $item->next_siblings();
209 my @next_siblings = $item->next_siblings();
211 Returns a resultset of all objects in the same group
212 positioned after the object on which this method was called.
214 Underneath calls L<DBIx::Class::ResultSet/search>, and therefore returns
215 objects by implicitly invoking L<C<< ->all() >>|DBIx::Class::ResultSet/all>
221 my $position_column = $self->position_column;
222 my $position = $self->get_column ($position_column);
224 DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS
228 ! eval { fail_on_internal_call; 1 }
230 die "ILLEGAL LIST CONTEXT INVOCATION: $@";
232 # *MUST* be context sensitive due to legacy (DO NOT call search_rs)
234 ? $self->_siblings->search ({ $position_column => { '>', $position } })
239 =head2 previous_sibling
241 my $sibling = $item->previous_sibling();
243 Returns the sibling that resides one position back. Returns 0
244 if the current object is the first one.
248 sub previous_sibling {
250 my $position_column = $self->position_column;
252 my $psib = $self->previous_siblings->search(
254 { rows => 1, order_by => { '-desc' => $position_column } },
257 return defined( $psib ) ? $psib : 0;
262 my $sibling = $item->first_sibling();
264 Returns the first sibling object, or 0 if the first sibling
271 my $position_column = $self->position_column;
273 my $fsib = $self->previous_siblings->search(
275 { rows => 1, order_by => { '-asc' => $position_column } },
278 return defined( $fsib ) ? $fsib : 0;
283 my $sibling = $item->next_sibling();
285 Returns the sibling that resides one position forward. Returns 0
286 if the current object is the last one.
292 my $position_column = $self->position_column;
293 my $nsib = $self->next_siblings->search(
295 { rows => 1, order_by => { '-asc' => $position_column } },
298 return defined( $nsib ) ? $nsib : 0;
303 my $sibling = $item->last_sibling();
305 Returns the last sibling, or 0 if the last sibling is this
312 my $position_column = $self->position_column;
313 my $lsib = $self->next_siblings->search(
315 { rows => 1, order_by => { '-desc' => $position_column } },
318 return defined( $lsib ) ? $lsib : 0;
321 # an optimized method to get the last sibling position value without inflating a result object
322 sub _last_sibling_posval {
324 my $position_column = $self->position_column;
326 my $cursor = $self->next_siblings->search(
328 { rows => 1, order_by => { '-desc' => $position_column }, select => $position_column },
336 $item->move_previous();
338 Swaps position with the sibling in the position previous in
339 the list. Returns 1 on success, and 0 if the object is
340 already the first one.
346 return $self->move_to ($self->_position - 1);
353 Swaps position with the sibling in the next position in the
354 list. Returns 1 on success, and 0 if the object is already
355 the last in the list.
361 return 0 unless defined $self->_last_sibling_posval; # quick way to check for no more siblings
362 return $self->move_to ($self->_position + 1);
369 Moves the object to the first position in the list. Returns 1
370 on success, and 0 if the object is already the first.
375 return shift->move_to( 1 );
382 Moves the object to the last position in the list. Returns 1
383 on success, and 0 if the object is already the last one.
389 my $last_posval = $self->_last_sibling_posval;
391 return 0 unless defined $last_posval;
393 return $self->move_to( $self->_position_from_value ($last_posval) );
398 $item->move_to( $position );
400 Moves the object to the specified position. Returns 1 on
401 success, and 0 if the object is already at the specified
407 my( $self, $to_position ) = @_;
408 return 0 if ( $to_position < 1 );
410 my $position_column = $self->position_column;
412 my $rsrc = $self->result_source;
415 if ($is_txn = $rsrc->schema->storage->transaction_depth) {
416 # Reload position state from storage
417 # The thinking here is that if we are in a transaction, it is
418 # *more likely* the object went out of sync due to resultset
419 # level shenanigans. Instead of always reloading (slow) - go
420 # ahead and hand-hold only in the case of higher layers
421 # requesting the safety of a txn
426 ->search($self->_storage_ident_condition, { rows => 1, columns => $position_column })
429 )[0] || $self->throw_exception(
430 sprintf "Unable to locate object '%s' in storage - object went ouf of sync...?",
434 delete $self->{_dirty_columns}{$position_column};
436 elsif ($self->is_column_changed ($position_column) ) {
437 # something changed our position, we need to know where we
438 # used to be - use the stashed value
439 $self->store_column($position_column, delete $self->{_column_data_in_storage}{$position_column});
440 delete $self->{_dirty_columns}{$position_column};
443 my $from_position = $self->_position;
445 if ( $from_position == $to_position ) { # FIXME this will not work for non-numeric order
449 my $guard = $is_txn ? undef : $rsrc->schema->txn_scope_guard;
451 my ($direction, @between);
452 if ( $from_position < $to_position ) {
454 @between = map { $self->_position_value ($_) } ( $from_position + 1, $to_position );
458 @between = map { $self->_position_value ($_) } ( $to_position, $from_position - 1 );
461 my $new_pos_val = $self->_position_value ($to_position); # record this before the shift
463 # we need to null-position the moved row if the position column is part of a constraint
464 if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $rsrc->unique_constraints }} ) ) ) {
465 $self->_ordered_internal_update({ $position_column => $self->null_position_value });
468 $self->_shift_siblings ($direction, @between);
469 $self->_ordered_internal_update({ $position_column => $new_pos_val });
471 $guard->commit if $guard;
477 $item->move_to_group( $group, $position );
479 Moves the object to the specified position of the specified
480 group, or to the end of the group if $position is undef.
481 1 is returned on success, and 0 is returned if the object is
482 already at the specified position of the specified group.
484 $group may be specified as a single scalar if only one
485 grouping column is in use, or as a hashref of column => value pairs
486 if multiple grouping columns are in use.
491 my( $self, $to_group, $to_position ) = @_;
493 # if we're given a single value, turn it into a hashref
494 unless (ref $to_group eq 'HASH') {
495 my @gcols = $self->_grouping_columns;
497 $self->throw_exception ('Single group supplied for a multi-column group identifier') if @gcols > 1;
498 $to_group = {$gcols[0] => $to_group};
501 my $position_column = $self->position_column;
503 return 0 if ( defined($to_position) and $to_position < 1 );
505 # check if someone changed the _grouping_columns - this will
506 # prevent _is_in_group working, so we need to restore the
507 # original stashed values
508 for ($self->_grouping_columns) {
509 if ($self->is_column_changed ($_)) {
510 $self->store_column($_, delete $self->{_column_data_in_storage}{$_});
511 delete $self->{_dirty_columns}{$_};
515 if ($self->_is_in_group ($to_group) ) {
517 if (defined $to_position) {
518 $ret = $self->move_to ($to_position);
524 my $guard = $self->result_source->schema->txn_scope_guard;
526 # Move to end of current group to adjust siblings
529 $self->set_inflated_columns({ %$to_group, $position_column => undef });
530 my $new_group_last_posval = $self->_last_sibling_posval;
531 my $new_group_last_position = $self->_position_from_value (
532 $new_group_last_posval
535 if ( not defined($to_position) or $to_position > $new_group_last_position) {
537 $position_column => $new_group_last_position
538 ? $self->_next_position_value ( $new_group_last_posval )
539 : $self->_initial_position_value
543 my $bumped_pos_val = $self->_position_value ($to_position);
544 my @between = map { $self->_position_value ($_) } ($to_position, $new_group_last_position);
545 $self->_shift_siblings (1, @between); #shift right
546 $self->set_column( $position_column => $bumped_pos_val );
549 $self->_ordered_internal_update;
558 Overrides the DBIC insert() method by providing a default
559 position number. The default will be the number of rows in
560 the table +1, thus positioning the new record at the last position.
566 my $position_column = $self->position_column;
568 unless ($self->get_column($position_column)) {
569 my $lsib_posval = $self->_last_sibling_posval;
571 $position_column => (defined $lsib_posval
572 ? $self->_next_position_value ( $lsib_posval )
573 : $self->_initial_position_value
578 return $self->next::method( @_ );
583 Overrides the DBIC update() method by checking for a change
584 to the position and/or group columns. Movement within a
585 group or to another group is handled by repositioning
586 the appropriate siblings. Position defaults to the end
587 of a new group if it has been changed to undef.
594 # this is set by _ordered_internal_update()
595 return $self->next::method(@_) if $self->result_source->schema->{_ORDERED_INTERNAL_UPDATE};
598 $self->set_inflated_columns($upd) if $upd;
600 my $position_column = $self->position_column;
601 my @group_columns = $self->_grouping_columns;
603 # see if the order is already changed
604 my $changed_ordering_cols = { map { $_ => $self->get_column($_) } grep { $self->is_column_changed($_) } ($position_column, @group_columns) };
606 # nothing changed - short circuit
607 if (! keys %$changed_ordering_cols) {
608 return $self->next::method( undef, @_ );
610 elsif (grep { exists $changed_ordering_cols->{$_} } @group_columns ) {
611 $self->move_to_group(
612 # since the columns are already re-set the _grouping_clause is correct
613 # move_to_group() knows how to get the original storage values
614 { $self->_grouping_clause },
616 # The FIXME bit contradicts the documentation: POD states that
617 # when changing groups without supplying explicit positions in
618 # move_to_group(), we push the item to the end of the group.
619 # However when I was rewriting this, the position from the old
620 # group was clearly passed to the new one
621 # Probably needs to go away (by ribasushi)
622 (exists $changed_ordering_cols->{$position_column}
623 ? $changed_ordering_cols->{$position_column} # means there was a position change supplied with the update too
624 : $self->_position # FIXME! (replace with undef)
629 $self->move_to($changed_ordering_cols->{$position_column});
637 Overrides the DBIC delete() method by first moving the object
638 to the last position, then deleting it, thus ensuring the
639 integrity of the positions.
646 my $guard = $self->result_source->schema->txn_scope_guard;
650 $self->next::method( @_ );
657 # add the current position/group to the things we track old values for
658 sub _track_storage_value {
659 my ($self, $col) = @_;
661 $self->next::method($col)
663 grep { $_ eq $col } ($self->position_column, $self->_grouping_columns)
667 =head1 METHODS FOR EXTENDING ORDERED
669 You would want to override the methods below if you use sparse
670 (non-linear) or non-numeric position values. This can be useful
671 if you are working with preexisting non-normalised position data,
672 or if you need to work with materialized path columns.
674 =head2 _position_from_value
676 my $num_pos = $item->_position_from_value ( $pos_value )
678 Returns the B<absolute numeric position> of an object with a B<position
679 value> set to C<$pos_value>. By default simply returns C<$pos_value>.
682 sub _position_from_value {
683 my ($self, $val) = @_;
685 return 0 unless defined $val;
687 # #the right way to do this
688 # return $self -> _group_rs
689 # -> search({ $self->position_column => { '<=', $val } })
695 =head2 _position_value
697 my $pos_value = $item->_position_value ( $pos )
699 Returns the B<value> of L</position_column> of the object at numeric
700 position C<$pos>. By default simply returns C<$pos>.
703 sub _position_value {
704 my ($self, $pos) = @_;
706 # #the right way to do this (not optimized)
707 # my $position_column = $self->position_column;
708 # return $self -> _group_rs
709 # -> search({}, { order_by => $position_column })
710 # -> slice ( $pos - 1)
712 # -> get_column ($position_column);
717 =head2 _initial_position_value
719 __PACKAGE__->_initial_position_value(0);
721 This method specifies a B<value> of L</position_column> which is assigned
722 to the first inserted element of a group, if no value was supplied at
723 insertion time. All subsequent values are derived from this one by
724 L</_next_position_value> below. Defaults to 1.
728 __PACKAGE__->mk_classaccessor( '_initial_position_value' => 1 );
730 =head2 _next_position_value
732 my $new_value = $item->_next_position_value ( $position_value )
734 Returns a position B<value> that would be considered C<next> with
735 regards to C<$position_value>. Can be pretty much anything, given
736 that C<< $position_value < $new_value >> where C<< < >> is the
737 SQL comparison operator (usually works fine on strings). The
738 default method expects C<$position_value> to be numeric, and
739 returns C<$position_value + 1>
742 sub _next_position_value {
746 =head2 _shift_siblings
748 $item->_shift_siblings ($direction, @between)
750 Shifts all siblings with B<positions values> in the range @between
751 (inclusive) by one position as specified by $direction (left if < 0,
752 right if > 0). By default simply increments/decrements each
753 L</position_column> value by 1, doing so in a way as to not violate
754 any existing constraints.
756 Note that if you override this method and have unique constraints
757 including the L</position_column> the shift is not a trivial task.
758 Refer to the implementation source of the default method for more
762 sub _shift_siblings {
763 my ($self, $direction, @between) = @_;
764 return 0 unless $direction;
766 my $position_column = $self->position_column;
769 if ($direction < 0) {
778 my $shift_rs = $self->_group_rs-> search ({ $position_column => { -between => \@between } });
780 # some databases (sqlite, pg, perhaps others) are dumb and can not do a
781 # blanket increment/decrement without violating a unique constraint.
782 # So what we do here is check if the position column is part of a unique
783 # constraint, and do a one-by-one update if this is the case.
784 my $rsrc = $self->result_source;
786 # set in case there are more cascades combined with $rs->update => $rs_update_all overrides
787 local $rsrc->schema->{_ORDERED_INTERNAL_UPDATE} = 1;
788 my @pcols = $rsrc->primary_columns;
790 grep { $_ eq $position_column } ( map { @$_ } (values %{{ $rsrc->unique_constraints }} ) )
792 my $clean_rs = $rsrc->resultset;
794 for ( $shift_rs->search (
795 {}, { order_by => { "-$ord", $position_column }, select => [$position_column, @pcols] }
798 $clean_rs->find(@$_)->update ({ $position_column => $pos + ( ($op eq '+') ? 1 : -1 ) });
802 $shift_rs->update ({ $position_column => \ "$position_column $op 1" } );
807 # This method returns a resultset containing all members of the row
808 # group (including the row itself).
812 DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS
816 ! eval { fail_on_internal_call; 1 }
818 die "ILLEGAL LIST CONTEXT INVOCATION: $@";
820 # *MUST* be context sensitive due to legacy (DO NOT call search_rs)
821 $_[0]->result_source->resultset->search({ $_[0]->_grouping_clause() });
824 # Returns an unordered resultset of all objects in the same group
825 # excluding the object you called this method on.
828 my $position_column = $self->position_column;
831 DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS
835 ! eval { fail_on_internal_call; 1 }
837 die "ILLEGAL LIST CONTEXT INVOCATION: $@";
839 # *MUST* be context sensitive due to legacy (DO NOT call search_rs)
840 defined( $pos = $self->get_column($position_column) )
841 ? $self->_group_rs->search(
842 { $position_column => { '!=' => $pos } },
848 # Returns the B<absolute numeric position> of the current object, with the
849 # first object being at position 1, its sibling at position 2 and so on.
852 return $self->_position_from_value ($self->get_column ($self->position_column) );
855 # This method returns one or more name=>value pairs for limiting a search
856 # by the grouping column(s). If the grouping column is not defined then
857 # this will return an empty list.
858 sub _grouping_clause {
860 return map { $_ => $self->get_column($_) } $self->_grouping_columns();
863 # Returns a list of the column names used for grouping, regardless of whether
864 # they were specified as an arrayref or a single string, and returns ()
865 # if there is no grouping.
866 sub _grouping_columns {
868 my $col = $self->grouping_column();
869 if (ref $col eq 'ARRAY') {
878 # Returns true if the object is in the group represented by hashref $other
880 my ($self, $other) = @_;
881 my $current = {$self->_grouping_clause};
891 defined( $current->{$_} )
893 defined( $other->{$_} )
897 defined $current->{$_}
899 $current->{$_} ne $other->{$_}
905 # This is a short-circuited method, that is used internally by this
906 # module to update positioning values in isolation (i.e. without
907 # triggering any of the positioning integrity code).
909 # Some day you might get confronted by datasets that have ambiguous
910 # positioning data (e.g. duplicate position values within the same group,
911 # in a table without unique constraints). When manually fixing such data
912 # keep in mind that you can not invoke L<DBIx::Class::Row/update> like
913 # you normally would, as it will get confused by the wrong data before
914 # having a chance to update the ill-defined row. If you really know what
915 # you are doing use this method which bypasses any hooks introduced by
917 sub _ordered_internal_update {
918 local $_[0]->result_source->schema->{_ORDERED_INTERNAL_UPDATE} = 1;
928 =head2 Resultset Methods
930 Note that all Insert/Create/Delete overrides are happening on
931 L<DBIx::Class::Row> methods only. If you use the
932 L<DBIx::Class::ResultSet> versions of
933 L<update|DBIx::Class::ResultSet/update> or
934 L<delete|DBIx::Class::ResultSet/delete>, all logic present in this
935 module will be bypassed entirely (possibly resulting in a broken
936 order-tree). Instead always use the
937 L<update_all|DBIx::Class::ResultSet/update_all> and
938 L<delete_all|DBIx::Class::ResultSet/delete_all> methods, which will
939 invoke the corresponding L<row|DBIx::Class::Row> method on every
940 member of the given resultset.
942 =head2 Race Condition on Insert
944 If a position is not specified for an insert, a position
945 will be chosen based either on L</_initial_position_value> or
946 L</_next_position_value>, depending if there are already some
947 items in the current group. The space of time between the
948 necessary selects and insert introduces a race condition.
949 Having unique constraints on your position/group columns,
950 and using transactions (see L<DBIx::Class::Storage/txn_do>)
951 will prevent such race conditions going undetected.
953 =head2 Multiple Moves
955 If you have multiple same-group result objects already loaded from storage,
956 you need to be careful when executing C<move_*> operations on them:
957 without a L</position_column> reload the L</_position_value> of the
958 "siblings" will be out of sync with the underlying storage.
960 Starting from version C<0.082800> DBIC will implicitly perform such
961 reloads when the C<move_*> happens as a part of a transaction
962 (a good example of such situation is C<< $ordered_resultset->delete_all >>).
964 If it is not possible for you to wrap the entire call-chain in a transaction,
965 you will need to call L<DBIx::Class::Row/discard_changes> to get an object
966 up-to-date before proceeding, otherwise undefined behavior will result.
968 =head2 Default Values
970 Using a database defined default_value on one of your group columns
971 could result in the position not being assigned correctly.
973 =head1 FURTHER QUESTIONS?
975 Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
977 =head1 COPYRIGHT AND LICENSE
979 This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
980 by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
981 redistribute it and/or modify it under the same terms as the
982 L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.