1 package DBIx::Class::Ordered;
4 use base qw( DBIx::Class );
8 DBIx::Class::Ordered - Modify the position of objects in an ordered list.
12 Create a table for your ordered data.
15 item_id INTEGER PRIMARY KEY AUTOINCREMENT,
17 position INTEGER NOT NULL
20 Optionally, add one or more columns to specify groupings, allowing you
21 to maintain independent ordered lists within one table:
24 item_id INTEGER PRIMARY KEY AUTOINCREMENT,
26 position INTEGER NOT NULL,
27 group_id INTEGER NOT NULL
33 item_id INTEGER PRIMARY KEY AUTOINCREMENT,
35 position INTEGER NOT NULL,
36 group_id INTEGER NOT NULL,
37 other_group_id INTEGER NOT NULL
40 In your Schema or DB class add "Ordered" to the top
41 of the component list.
43 __PACKAGE__->load_components(qw( Ordered ... ));
45 Specify the column that stores the position number for
49 __PACKAGE__->position_column('position');
51 If you are using one grouping column, specify it as follows:
53 __PACKAGE__->grouping_column('group_id');
55 Or if you have multiple grouping columns:
57 __PACKAGE__->grouping_column(['group_id', 'other_group_id']);
59 That's it, now you can change the position of your objects.
64 my $item = My::Item->create({ name=>'Matt S. Trout' });
65 # If using grouping_column:
66 my $item = My::Item->create({ name=>'Matt S. Trout', group_id=>1 });
68 my $rs = $item->siblings();
69 my @siblings = $item->siblings();
72 $sibling = $item->first_sibling();
73 $sibling = $item->last_sibling();
74 $sibling = $item->previous_sibling();
75 $sibling = $item->next_sibling();
77 $item->move_previous();
81 $item->move_to( $position );
82 $item->move_to_group( 'groupname' );
83 $item->move_to_group( 'groupname', $position );
84 $item->move_to_group( {group_id=>'groupname', 'other_group_id=>'othergroupname'} );
85 $item->move_to_group( {group_id=>'groupname', 'other_group_id=>'othergroupname'}, $position );
89 This module provides a simple interface for modifying the ordered
90 position of DBIx::Class objects.
94 All of the move_* methods automatically update the rows involved in
95 the query. This is not configurable and is due to the fact that if you
96 move a record it always causes other records in the list to be updated.
100 =head2 position_column
102 __PACKAGE__->position_column('position');
104 Sets and retrieves the name of the column that stores the
105 positional value of each record. Defaults to "position".
109 __PACKAGE__->mk_classdata( 'position_column' => 'position' );
111 =head2 grouping_column
113 __PACKAGE__->grouping_column('group_id');
115 This method specifies a column to limit all queries in
116 this module by. This effectively allows you to have multiple
117 ordered lists within the same table.
121 __PACKAGE__->mk_classdata( 'grouping_column' );
123 =head2 null_position_value
125 __PACKAGE__->null_position_value(undef);
127 This method specifies a value of L</position_column> which B<would
128 never be assigned to a row> during normal operation. When
129 a row is moved, its position is set to this value temporarily, so
130 that any unique constraints can not be violated. This value defaults
131 to 0, which should work for all cases except when your positions do
136 __PACKAGE__->mk_classdata( 'null_position_value' => 0 );
140 my $rs = $item->siblings();
141 my @siblings = $item->siblings();
143 Returns an B<ordered> resultset of all other objects in the same
144 group excluding the one you called it on.
146 The ordering is a backwards-compatibility artifact - if you need
147 a resultset with no ordering applied use L</_siblings>
152 return $self->_siblings->search ({}, { order_by => $self->position_column } );
155 =head2 previous_siblings
157 my $prev_rs = $item->previous_siblings();
158 my @prev_siblings = $item->previous_siblings();
160 Returns a resultset of all objects in the same group
161 positioned before the object on which this method was called.
164 sub previous_siblings {
166 my $position_column = $self->position_column;
167 my $position = $self->get_column ($position_column);
168 return ( defined $position
169 ? $self->_siblings->search ({ $position_column => { '<', $position } })
176 my $next_rs = $item->next_siblings();
177 my @next_siblings = $item->next_siblings();
179 Returns a resultset of all objects in the same group
180 positioned after the object on which this method was called.
185 my $position_column = $self->position_column;
186 my $position = $self->get_column ($position_column);
187 return ( defined $position
188 ? $self->_siblings->search ({ $position_column => { '>', $position } })
193 =head2 previous_sibling
195 my $sibling = $item->previous_sibling();
197 Returns the sibling that resides one position back. Returns 0
198 if the current object is the first one.
202 sub previous_sibling {
204 my $position_column = $self->position_column;
206 my $psib = $self->previous_siblings->search(
208 { rows => 1, order_by => { '-desc' => $position_column } },
211 return defined $psib ? $psib : 0;
216 my $sibling = $item->first_sibling();
218 Returns the first sibling object, or 0 if the first sibling
225 my $position_column = $self->position_column;
227 my $fsib = $self->previous_siblings->search(
229 { rows => 1, order_by => { '-asc' => $position_column } },
232 return defined $fsib ? $fsib : 0;
237 my $sibling = $item->next_sibling();
239 Returns the sibling that resides one position forward. Returns 0
240 if the current object is the last one.
246 my $position_column = $self->position_column;
247 my $nsib = $self->next_siblings->search(
249 { rows => 1, order_by => { '-asc' => $position_column } },
252 return defined $nsib ? $nsib : 0;
257 my $sibling = $item->last_sibling();
259 Returns the last sibling, or 0 if the last sibling is this
266 my $position_column = $self->position_column;
267 my $lsib = $self->next_siblings->search(
269 { rows => 1, order_by => { '-desc' => $position_column } },
272 return defined $lsib ? $lsib : 0;
275 # an optimized method to get the last sibling position value without inflating a row object
276 sub _last_sibling_posval {
278 my $position_column = $self->position_column;
280 my $cursor = $self->next_siblings->search(
282 { rows => 1, order_by => { '-desc' => $position_column }, select => $position_column },
285 my ($pos) = $cursor->next;
291 $item->move_previous();
293 Swaps position with the sibling in the position previous in
294 the list. Returns 1 on success, and 0 if the object is
295 already the first one.
301 return $self->move_to ($self->_position - 1);
308 Swaps position with the sibling in the next position in the
309 list. Returns 1 on success, and 0 if the object is already
310 the last in the list.
316 return 0 unless defined $self->_last_sibling_posval; # quick way to check for no more siblings
317 return $self->move_to ($self->_position + 1);
324 Moves the object to the first position in the list. Returns 1
325 on success, and 0 if the object is already the first.
330 return shift->move_to( 1 );
337 Moves the object to the last position in the list. Returns 1
338 on success, and 0 if the object is already the last one.
344 my $last_posval = $self->_last_sibling_posval;
346 return 0 unless defined $last_posval;
348 return $self->move_to( $self->_position_from_value ($last_posval) );
353 $item->move_to( $position );
355 Moves the object to the specified position. Returns 1 on
356 success, and 0 if the object is already at the specified
362 my( $self, $to_position ) = @_;
363 return 0 if ( $to_position < 1 );
365 my $position_column = $self->position_column;
369 if ($self->is_column_changed ($position_column) ) {
370 # something changed our position, we have no idea where we
371 # used to be - requery without using discard_changes
372 # (we need only a specific column back)
374 $guard = $self->result_source->schema->txn_scope_guard;
376 my $cursor = $self->result_source->resultset->search(
377 $self->ident_condition,
378 { select => $position_column },
381 my ($pos) = $cursor->next;
382 $self->$position_column ($pos);
383 delete $self->{_dirty_columns}{$position_column};
386 my $from_position = $self->_position;
388 if ( $from_position == $to_position ) { # FIXME this will not work for non-numeric order
389 $guard->commit if $guard;
393 $guard ||= $self->result_source->schema->txn_scope_guard;
395 my ($direction, @between);
396 if ( $from_position < $to_position ) {
398 @between = map { $self->_position_value ($_) } ( $from_position + 1, $to_position );
402 @between = map { $self->_position_value ($_) } ( $to_position, $from_position - 1 );
405 my $new_pos_val = $self->_position_value ($to_position); # record this before the shift
407 # we need to null-position the moved row if the position column is part of a constraint
408 if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $self->result_source->unique_constraints }} ) ) ) {
409 $self->_ordered_internal_update({ $position_column => $self->null_position_value });
412 $self->_shift_siblings ($direction, @between);
413 $self->_ordered_internal_update({ $position_column => $new_pos_val });
421 $item->move_to_group( $group, $position );
423 Moves the object to the specified position of the specified
424 group, or to the end of the group if $position is undef.
425 1 is returned on success, and 0 is returned if the object is
426 already at the specified position of the specified group.
428 $group may be specified as a single scalar if only one
429 grouping column is in use, or as a hashref of column => value pairs
430 if multiple grouping columns are in use.
435 my( $self, $to_group, $to_position ) = @_;
437 # if we're given a single value, turn it into a hashref
438 unless (ref $to_group eq 'HASH') {
439 my @gcols = $self->_grouping_columns;
441 $self->throw_exception ('Single group supplied for a multi-column group identifier') if @gcols > 1;
442 $to_group = {$gcols[0] => $to_group};
445 my $position_column = $self->position_column;
447 return 0 if ( defined($to_position) and $to_position < 1 );
449 # check if someone changed the _grouping_columns - this will
450 # prevent _is_in_group working, so we need to requery the db
451 # for the original values
452 my (@dirty_cols, %values, $guard);
453 for ($self->_grouping_columns) {
454 $values{$_} = $self->get_column ($_);
455 push @dirty_cols, $_ if $self->is_column_changed ($_);
458 # re-query only the dirty columns, and restore them on the
459 # object (subsequent code will update them to the correct
462 $guard = $self->result_source->schema->txn_scope_guard;
464 my $cursor = $self->result_source->resultset->search(
465 $self->ident_condition,
466 { select => \@dirty_cols },
469 my @original_values = $cursor->next;
470 $self->set_inflated_columns ({ %values, map { $_ => shift @original_values } (@dirty_cols) });
471 delete $self->{_dirty_columns}{$_} for (@dirty_cols);
474 if ($self->_is_in_group ($to_group) ) {
476 if (defined $to_position) {
477 $ret = $self->move_to ($to_position);
480 $guard->commit if $guard;
484 $guard ||= $self->result_source->schema->txn_scope_guard;
486 # Move to end of current group to adjust siblings
489 $self->set_inflated_columns({ %$to_group, $position_column => undef });
490 my $new_group_last_posval = $self->_last_sibling_posval;
491 my $new_group_last_position = $self->_position_from_value (
492 $new_group_last_posval
495 if ( not defined($to_position) or $to_position > $new_group_last_position) {
497 $position_column => $new_group_last_position
498 ? $self->_next_position_value ( $new_group_last_posval )
499 : $self->_initial_position_value
503 my $bumped_pos_val = $self->_position_value ($to_position);
504 my @between = map { $self->_position_value ($_) } ($to_position, $new_group_last_position);
505 $self->_shift_siblings (1, @between); #shift right
506 $self->set_column( $position_column => $bumped_pos_val );
509 $self->_ordered_internal_update;
518 Overrides the DBIC insert() method by providing a default
519 position number. The default will be the number of rows in
520 the table +1, thus positioning the new record at the last position.
526 my $position_column = $self->position_column;
528 unless ($self->get_column($position_column)) {
529 my $lsib_posval = $self->_last_sibling_posval;
531 $position_column => (defined $lsib_posval
532 ? $self->_next_position_value ( $lsib_posval )
533 : $self->_initial_position_value
538 return $self->next::method( @_ );
543 Overrides the DBIC update() method by checking for a change
544 to the position and/or group columns. Movement within a
545 group or to another group is handled by repositioning
546 the appropriate siblings. Position defaults to the end
547 of a new group if it has been changed to undef.
554 # this is set by _ordered_internal_update()
555 return $self->next::method(@_) if $self->{_ORDERED_INTERNAL_UPDATE};
557 my $position_column = $self->position_column;
558 my @ordering_columns = ($self->_grouping_columns, $position_column);
561 # these steps are necessary to keep the external appearance of
562 # ->update($upd) so that other things overloading update() will
564 my %original_values = $self->get_columns;
565 my %existing_changes = $self->get_dirty_columns;
567 # See if any of the *supplied* changes would affect the ordering
568 # The reason this is so contrived, is that we want to leverage
569 # the datatype aware value comparing, while at the same time
570 # keep the original value intact (it will be updated later by the
571 # corresponding routine)
573 my %upd = %{shift || {}};
574 my %changes = %existing_changes;
576 for (@ordering_columns) {
577 next unless exists $upd{$_};
579 # we do not want to keep propagating this to next::method
580 # as it will be a done deal by the time get there
581 my $value = delete $upd{$_};
582 $self->set_inflated_columns ({ $_ => $value });
584 # see if an update resulted in a dirty column
585 # it is important to preserve the old value, as it
586 # will be needed to carry on a successfull move()
587 # operation without re-querying the database
588 if ($self->is_column_changed ($_) && not exists $existing_changes{$_}) {
589 $changes{$_} = $value;
590 $self->set_inflated_columns ({ $_ => $original_values{$_} });
591 delete $self->{_dirty_columns}{$_};
595 # if nothing group/position related changed - short circuit
596 if (not grep { exists $changes{$_} } ( @ordering_columns ) ) {
597 return $self->next::method( \%upd, @_ );
601 my $guard = $self->result_source->schema->txn_scope_guard;
603 # if any of our grouping columns have been changed
604 if (grep { exists $changes{$_} } ($self->_grouping_columns) ) {
606 # create new_group by taking the current group and inserting changes
607 my $new_group = {$self->_grouping_clause};
608 foreach my $col (keys %$new_group) {
609 $new_group->{$col} = $changes{$col} if exists $changes{$col};
612 $self->move_to_group(
614 (exists $changes{$position_column}
615 # The FIXME bit contradicts the documentation: POD states that
616 # when changing groups without supplying explicit positions in
617 # move_to_group(), we push the item to the end of the group.
618 # However when I was rewriting this, the position from the old
619 # group was clearly passed to the new one
620 # Probably needs to go away (by ribasushi)
621 ? $changes{$position_column} # means there was a position change supplied with the update too
622 : $self->_position # FIXME! (replace with undef)
626 elsif (exists $changes{$position_column}) {
627 $self->move_to($changes{$position_column});
631 my $want = wantarray();
632 if (not defined $want) {
633 $self->next::method( \%upd, @_ );
636 @res = $self->next::method( \%upd, @_ );
639 $res[0] = $self->next::method( \%upd, @_ );
643 return $want ? @res : $res[0];
649 Overrides the DBIC delete() method by first moving the object
650 to the last position, then deleting it, thus ensuring the
651 integrity of the positions.
658 my $guard = $self->result_source->schema->txn_scope_guard;
663 my $want = wantarray();
664 if (not defined $want) {
665 $self->next::method( @_ );
668 @res = $self->next::method( @_ );
671 $res[0] = $self->next::method( @_ );
675 return $want ? @res : $res[0];
678 =head1 METHODS FOR EXTENDING ORDERED
680 You would want to override the methods below if you use sparse
681 (non-linear) or non-numeric position values. This can be useful
682 if you are working with preexisting non-normalised position data,
683 or if you need to work with materialized path columns.
685 =head2 _position_from_value
687 my $num_pos = $item->_position_from_value ( $pos_value )
689 Returns the B<absolute numeric position> of an object with a B<position
690 value> set to C<$pos_value>. By default simply returns C<$pos_value>.
693 sub _position_from_value {
694 my ($self, $val) = @_;
696 return 0 unless defined $val;
698 # #the right way to do this
699 # return $self -> _group_rs
700 # -> search({ $self->position_column => { '<=', $val } })
706 =head2 _position_value
708 my $pos_value = $item->_position_value ( $pos )
710 Returns the B<value> of L</position_column> of the object at numeric
711 position C<$pos>. By default simply returns C<$pos>.
714 sub _position_value {
715 my ($self, $pos) = @_;
717 # #the right way to do this (not optimized)
718 # my $position_column = $self->position_column;
719 # return $self -> _group_rs
720 # -> search({}, { order_by => $position_column })
721 # -> slice ( $pos - 1)
723 # -> get_column ($position_column);
728 =head2 _initial_position_value
730 __PACKAGE__->_initial_position_value(0);
732 This method specifies a B<value> of L</position_column> which is assigned
733 to the first inserted element of a group, if no value was supplied at
734 insertion time. All subsequent values are derived from this one by
735 L</_next_position_value> below. Defaults to 1.
739 __PACKAGE__->mk_classdata( '_initial_position_value' => 1 );
741 =head2 _next_position_value
743 my $new_value = $item->_next_position_value ( $position_value )
745 Returns a position B<value> that would be considered C<next> with
746 regards to C<$position_value>. Can be pretty much anything, given
747 that C<< $position_value < $new_value >> where C<< < >> is the
748 SQL comparison operator (usually works fine on strings). The
749 default method expects C<$position_value> to be numeric, and
750 returns C<$position_value + 1>
753 sub _next_position_value {
757 =head2 _shift_siblings
759 $item->_shift_siblings ($direction, @between)
761 Shifts all siblings with B<positions values> in the range @between
762 (inclusive) by one position as specified by $direction (left if < 0,
763 right if > 0). By default simply increments/decrements each
764 L<position_column> value by 1, doing so in a way as to not violate
765 any existing constraints.
767 Note that if you override this method and have unique constraints
768 including the L<position_column> the shift is not a trivial task.
769 Refer to the implementation source of the default method for more
773 sub _shift_siblings {
774 my ($self, $direction, @between) = @_;
775 return 0 unless $direction;
777 my $position_column = $self->position_column;
780 if ($direction < 0) {
789 my $shift_rs = $self->_group_rs-> search ({ $position_column => { -between => \@between } });
791 # some databases (sqlite) are dumb and can not do a blanket
792 # increment/decrement. So what we do here is check if the
793 # position column is part of a unique constraint, and do a
794 # one-by-one update if this is the case
796 my $rsrc = $self->result_source;
798 if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $rsrc->unique_constraints }} ) ) ) {
800 my @pcols = $rsrc->_pri_cols;
801 my $cursor = $shift_rs->search ({}, { order_by => { "-$ord", $position_column }, columns => \@pcols } )->cursor;
802 my $rs = $self->result_source->resultset;
804 my @all_pks = $cursor->all;
805 while (my $pks = shift @all_pks) {
807 for my $i (0.. $#pcols) {
808 $cond->{$pcols[$i]} = $pks->[$i];
811 $rs->search($cond)->update ({ $position_column => \ "$position_column $op 1" } );
815 $shift_rs->update ({ $position_column => \ "$position_column $op 1" } );
819 =head1 PRIVATE METHODS
821 These methods are used internally. You should never have the
826 This method returns a resultset containing all members of the row
827 group (including the row itself).
832 return $self->result_source->resultset->search({$self->_grouping_clause()});
837 Returns an unordered resultset of all objects in the same group
838 excluding the object you called this method on.
843 my $position_column = $self->position_column;
844 return $self->_group_rs->search(
845 { $position_column => { '!=' => $self->get_column($position_column) } },
851 my $num_pos = $item->_position;
853 Returns the B<absolute numeric position> of the current object, with the
854 first object being at position 1, its sibling at position 2 and so on.
859 return $self->_position_from_value ($self->get_column ($self->position_column) );
862 =head2 _grouping_clause
864 This method returns one or more name=>value pairs for limiting a search
865 by the grouping column(s). If the grouping column is not defined then
866 this will return an empty list.
869 sub _grouping_clause {
871 return map { $_ => $self->get_column($_) } $self->_grouping_columns();
874 =head2 _get_grouping_columns
876 Returns a list of the column names used for grouping, regardless of whether
877 they were specified as an arrayref or a single string, and returns ()
878 if there is no grouping.
881 sub _grouping_columns {
883 my $col = $self->grouping_column();
884 if (ref $col eq 'ARRAY') {
895 $item->_is_in_group( {user => 'fred', list => 'work'} )
897 Returns true if the object is in the group represented by hashref $other
901 my ($self, $other) = @_;
902 my $current = {$self->_grouping_clause};
904 no warnings qw/uninitialized/;
907 join ("\x00", sort keys %$current)
909 join ("\x00", sort keys %$other)
911 for my $key (keys %$current) {
912 return 0 if $current->{$key} ne $other->{$key};
917 =head2 _ordered_internal_update
919 This is a short-circuited method, that is used internally by this
920 module to update positioning values in isolation (i.e. without
921 triggering any of the positioning integrity code).
923 Some day you might get confronted by datasets that have ambiguous
924 positioning data (e.g. duplicate position values within the same group,
925 in a table without unique constraints). When manually fixing such data
926 keep in mind that you can not invoke L<DBIx::Class::Row/update> like
927 you normally would, as it will get confused by the wrong data before
928 having a chance to update the ill-defined row. If you really know what
929 you are doing use this method which bypasses any hooks introduced by
934 sub _ordered_internal_update {
936 local $self->{_ORDERED_INTERNAL_UPDATE} = 1;
937 return $self->update (@_);
946 =head2 Resultset Methods
948 Note that all Insert/Create/Delete overrides are happening on
949 L<DBIx::Class::Row> methods only. If you use the
950 L<DBIx::Class::ResultSet> versions of
951 L<update|DBIx::Class::ResultSet/update> or
952 L<delete|DBIx::Class::ResultSet/delete>, all logic present in this
953 module will be bypassed entirely (possibly resulting in a broken
954 order-tree). Instead always use the
955 L<update_all|DBIx::Class::ResultSet/update_all> and
956 L<delete_all|DBIx::Class::ResultSet/delete_all> methods, which will
957 invoke the corresponding L<row|DBIx::Class::Row> method on every
958 member of the given resultset.
960 =head2 Race Condition on Insert
962 If a position is not specified for an insert, a position
963 will be chosen based either on L</_initial_position_value> or
964 L</_next_position_value>, depending if there are already some
965 items in the current group. The space of time between the
966 necessary selects and insert introduces a race condition.
967 Having unique constraints on your position/group columns,
968 and using transactions (see L<DBIx::Class::Storage/txn_do>)
969 will prevent such race conditions going undetected.
971 =head2 Multiple Moves
973 Be careful when issuing move_* methods to multiple objects. If
974 you've pre-loaded the objects then when you move one of the objects
975 the position of the other object will not reflect their new value
976 until you reload them from the database - see
977 L<DBIx::Class::Row/discard_changes>.
979 There are times when you will want to move objects as groups, such
980 as changing the parent of several objects at once - this directly
981 conflicts with this problem. One solution is for us to write a
982 ResultSet class that supports a parent() method, for example. Another
983 solution is to somehow automagically modify the objects that exist
984 in the current object's result set to have the new position value.
986 =head2 Default Values
988 Using a database defined default_value on one of your group columns
989 could result in the position not being assigned correctly.
993 Original code framework
994 Aran Deltac <bluefeet@cpan.org>
996 Constraints support and code generalisation
997 Peter Rabbitson <ribasushi@cpan.org>
1001 You may distribute this code under the same terms as Perl itself.