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 constrainst 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 $self->throw_exception ('move_to_group() expects a group specification')
438 unless defined $to_group;
440 # if we're given a string, turn it into a hashref
441 unless (ref $to_group eq 'HASH') {
442 my @gcols = $self->_grouping_columns;
444 $self->throw_exception ('Single group supplied for a multi-column group identifier') if @gcols > 1;
445 $to_group = {$gcols[0] => $to_group};
448 my $position_column = $self->position_column;
450 return 0 if ( defined($to_position) and $to_position < 1 );
452 # check if someone changed the _grouping_columns - this will
453 # prevent _is_in_group working, so we need to requery the db
454 # for the original values
455 my (@dirty_cols, %values, $guard);
456 for ($self->_grouping_columns) {
457 $values{$_} = $self->get_column ($_);
458 push @dirty_cols, $_ if $self->is_column_changed ($_);
461 # re-query only the dirty columns, and restore them on the
462 # object (subsequent code will update them to the correct
465 $guard = $self->result_source->schema->txn_scope_guard;
467 my $cursor = $self->result_source->resultset->search(
468 $self->ident_condition,
469 { select => \@dirty_cols },
472 my @original_values = $cursor->next;
473 $self->set_inflated_columns ({ %values, map { $_ => shift @original_values } (@dirty_cols) });
476 if ($self->_is_in_group ($to_group) ) {
478 if (defined $to_position) {
479 $ret = $self->move_to ($to_position);
482 $guard->commit if $guard;
486 $guard ||= $self->result_source->schema->txn_scope_guard;
488 # Move to end of current group to adjust siblings
491 $self->set_inflated_columns({ %$to_group, $position_column => undef });
492 my $new_group_last_posval = $self->_last_sibling_posval;
493 my $new_group_last_position = $self->_position_from_value (
494 $new_group_last_posval
497 if ( not defined($to_position) or $to_position > $new_group_last_position) {
499 $position_column => $new_group_last_position
500 ? $self->_next_position_value ( $new_group_last_posval )
501 : $self->_initial_position_value
505 my $bumped_pos_val = $self->_position_value ($to_position);
506 my @between = ($to_position, $new_group_last_position);
507 $self->_shift_siblings (1, @between); #shift right
508 $self->set_column( $position_column => $bumped_pos_val );
511 $self->_ordered_internal_update;
520 Overrides the DBIC insert() method by providing a default
521 position number. The default will be the number of rows in
522 the table +1, thus positioning the new record at the last position.
528 my $position_column = $self->position_column;
530 unless ($self->get_column($position_column)) {
531 my $lsib_posval = $self->_last_sibling_posval;
533 $position_column => (defined $lsib_posval
534 ? $self->_next_position_value ( $lsib_posval )
535 : $self->_initial_position_value
540 return $self->next::method( @_ );
545 Overrides the DBIC update() method by checking for a change
546 to the position and/or group columns. Movement within a
547 group or to another group is handled by repositioning
548 the appropriate siblings. Position defaults to the end
549 of a new group if it has been changed to undef.
556 # this is set by _ordered_internal_update()
557 return $self->next::method(@_) if $self->{_ORDERED_INTERNAL_UPDATE};
559 my $position_column = $self->position_column;
560 my @ordering_columns = ($self->_grouping_columns, $position_column);
563 # these steps are necessary to keep the external appearance of
564 # ->update($upd) so that other things overloading update() will
566 my %original_values = $self->get_inflated_columns;
567 my %existing_changes = $self->get_dirty_columns;
569 # See if any of the *supplied* changes would affect the ordering
570 # The reason this is so contrived, is that we want to leverage
571 # the datatype aware value comparing, while at the same time
572 # keep the original value intact (it will be updated later by the
573 # corresponding routine)
575 my %upd = %{shift || {}};
576 my %changes = %existing_changes;
578 for (@ordering_columns) {
579 next unless exists $upd{$_};
581 # we do not want to keep propagating this to next::method
582 # as it will be a done deal by the time get there
583 my $value = delete $upd{$_};
584 $self->set_inflated_columns ({ $_ => $value });
586 # see if an update resulted in a dirty column
587 # it is important to preserve the old value, as it
588 # will be needed to carry on a successfull move()
589 # operation without re-querying the database
590 if ($self->is_column_changed ($_) && not exists $existing_changes{$_}) {
591 $changes{$_} = $value;
592 $self->set_inflated_columns ({ $_ => $original_values{$_} });
593 delete $self->{_dirty_columns}{$_};
597 # if nothing group/position related changed - short circuit
598 if (not grep { exists $changes{$_} } ( @ordering_columns ) ) {
599 return $self->next::method( \%upd, @_ );
603 my $guard = $self->result_source->schema->txn_scope_guard;
605 # if any of our grouping columns have been changed
606 if (grep { exists $changes{$_} } ($self->_grouping_columns) ) {
608 # create new_group by taking the current group and inserting changes
609 my $new_group = {$self->_grouping_clause};
610 foreach my $col (keys %$new_group) {
611 $new_group->{$col} = $changes{$col} if exists $changes{$col};
614 $self->move_to_group(
616 (exists $changes{$position_column}
617 # The FIXME bit contradicts the documentation: POD states that
618 # when changing groups without supplying explicit positions in
619 # move_to_group(), we push the item to the end of the group.
620 # However when I was rewriting this, the position from the old
621 # group was clearly passed to the new one
622 # Probably needs to go away (by ribasushi)
623 ? $changes{$position_column} # means there was a position change supplied with the update too
624 : $self->_position # FIXME! (replace with undef)
628 elsif (exists $changes{$position_column}) {
629 $self->move_to($changes{$position_column});
633 my $want = wantarray();
634 if (not defined $want) {
635 $self->next::method( \%upd, @_ );
638 @res = $self->next::method( \%upd, @_ );
641 $res[0] = $self->next::method( \%upd, @_ );
645 return $want ? @res : $res[0];
651 Overrides the DBIC delete() method by first moving the object
652 to the last position, then deleting it, thus ensuring the
653 integrity of the positions.
660 my $guard = $self->result_source->schema->txn_scope_guard;
665 my $want = wantarray();
666 if (not defined $want) {
667 $self->next::method( @_ );
670 @res = $self->next::method( @_ );
673 $res[0] = $self->next::method( @_ );
677 return $want ? @res : $res[0];
680 =head1 METHODS FOR EXTENDING ORDERED
682 You would want to override the methods below if you use sparse
683 (non-linear) or non-numeric position values. This can be useful
684 if you are working with preexisting non-normalised position data,
685 or if you need to work with materialized path columns.
689 my $num_pos = $item->_position;
691 Returns the B<absolute numeric position> of the current object, with the
692 first object being at position 1, its sibling at position 2 and so on.
693 By default simply returns the value of L</position_column>.
699 # #the right way to do this
700 # return $self->previous_siblings->count + 1;
702 return $self->get_column ($self->position_column);
705 =head2 _position_from_value
707 my $num_pos = $item->_position_of_value ( $pos_value )
709 Returns the B<absolute numeric position> of an object with a B<position
710 value> set to C<$pos_value>. By default simply returns C<$pos_value>.
713 sub _position_from_value {
714 my ($self, $val) = @_;
716 return 0 unless defined $val;
718 # #the right way to do this
719 # return $self -> _group_rs
720 # -> search({ $self->position_column => { '<=', $val } })
726 =head2 _position_value
728 my $pos_value = $item->_position_value ( $pos )
730 Returns the B<value> of L</position_column> of the object at numeric
731 position C<$pos>. By default simply returns C<$pos>.
734 sub _position_value {
735 my ($self, $pos) = @_;
737 # #the right way to do this (not optimized)
738 # my $position_column = $self->position_column;
739 # return $self -> _group_rs
740 # -> search({}, { order_by => $position_column })
741 # -> slice ( $pos - 1)
743 # -> get_column ($position_column);
748 =head2 _initial_position_value
750 __PACKAGE__->_initial_position_value(0);
752 This method specifies a B<value> of L</position_column> which is assigned
753 to the first inserted element of a group, if no value was supplied at
754 insertion time. All subsequent values are derived from this one by
755 L</_next_position_value> below. Defaults to 1.
759 __PACKAGE__->mk_classdata( '_initial_position_value' => 1 );
761 =head2 _next_position_value
763 my $new_value = $item->_next_position_value ( $position_value )
765 Returns a position B<value> that would be considered C<next> with
766 regards to C<$position_value>. Can be pretty much anything, given
767 that C<< $position_value < $new_value >> where C<< < >> is the
768 SQL comparison operator (usually works fine on strings). The
769 default method expects C<$position_value> to be numeric, and
770 returns C<$position_value + 1>
773 sub _next_position_value {
777 =head2 _shift_siblings
779 $item->_shift_siblings ($direction, @between)
781 Shifts all siblings with B<positions values> in the range @between
782 (inclusive) by one position as specified by $direction (left if < 0,
783 right if > 0). By default simply increments/decrements each
784 L<position_column> value by 1, doing so in a way as to not violate
785 any existing constraints.
787 Note that if you override this method and have unique constraints
788 including the L<position_column> the shift is not a trivial task.
789 Refer to the implementation source of the default method for more
793 sub _shift_siblings {
794 my ($self, $direction, @between) = @_;
795 return 0 unless $direction;
797 my $position_column = $self->position_column;
800 if ($direction < 0) {
809 my $shift_rs = $self->_group_rs-> search ({ $position_column => { -between => \@between } });
811 # some databases (sqlite) are dumb and can not do a blanket
812 # increment/decrement. So what we do here is check if the
813 # position column is part of a unique constraint, and do a
814 # one-by-one update if this is the case
816 my $rsrc = $self->result_source;
818 if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $rsrc->unique_constraints }} ) ) ) {
820 my @pcols = $rsrc->primary_columns;
821 my $cursor = $shift_rs->search ({}, { order_by => { "-$ord", $position_column }, columns => \@pcols } )->cursor;
822 my $rs = $self->result_source->resultset;
824 while (my @pks = $cursor->next ) {
827 for my $i (0.. $#pcols) {
828 $cond->{$pcols[$i]} = $pks[$i];
831 $rs->search($cond)->update ({ $position_column => \ "$position_column $op 1" } );
835 $shift_rs->update ({ $position_column => \ "$position_column $op 1" } );
839 =head1 PRIVATE METHODS
841 These methods are used internally. You should never have the
846 This method returns a resultset containing all members of the row
847 group (including the row itself).
852 return $self->result_source->resultset->search({$self->_grouping_clause()});
857 Returns an unordered resultset of all objects in the same group
858 excluding the object you called this method on.
863 my $position_column = $self->position_column;
864 return $self->_group_rs->search(
865 { $position_column => { '!=' => $self->get_column($position_column) } },
869 =head2 _grouping_clause
871 This method returns one or more name=>value pairs for limiting a search
872 by the grouping column(s). If the grouping column is not defined then
873 this will return an empty list.
876 sub _grouping_clause {
878 return map { $_ => $self->get_column($_) } $self->_grouping_columns();
881 =head2 _get_grouping_columns
883 Returns a list of the column names used for grouping, regardless of whether
884 they were specified as an arrayref or a single string, and returns ()
885 if there is no grouping.
888 sub _grouping_columns {
890 my $col = $self->grouping_column();
891 if (ref $col eq 'ARRAY') {
902 $item->_is_in_group( {user => 'fred', list => 'work'} )
904 Returns true if the object is in the group represented by hashref $other
908 my ($self, $other) = @_;
909 my $current = {$self->_grouping_clause};
911 no warnings qw/uninitialized/;
914 join ("\x00", sort keys %$current)
916 join ("\x00", sort keys %$other)
918 for my $key (keys %$current) {
919 return 0 if $current->{$key} ne $other->{$key};
924 =head2 _ordered_internal_update
926 This is a short-circuited method, that is used internally by this
927 module to update positioning values in isolation (i.e. without
928 triggering any of the positioning integrity code).
930 Some day you might get confronted by datasets that have ambiguous
931 positioning data (i.e. duplicate position values within the same group,
932 in a table without unique constraints). When manually fixing such data
933 keep in mind that you can not invoke L<DBIx::Class::Row/update> like
934 you normally would, as it will get confused by the wrong data before
935 having a chance to update the ill-defined row. If you really know what
936 you are doing use this method which bypasses any hooks introduced by
941 sub _ordered_internal_update {
943 local $self->{_ORDERED_INTERNAL_UPDATE} = 1;
944 return $self->update (@_);
953 =head2 Race Condition on Insert
955 If a position is not specified for an insert than a position
956 will be chosen based either on L</_initial_position_value> or
957 L</_next_position_value>, depending if there are already some
958 items in the current group. The space of time between the
959 necessary selects and insert introduces a race condition.
960 Having unique constraints on your position/group columns,
961 and using transactions (see L<DBIx::Class::Storage/txn_do>)
962 will prevent such race conditions going undetected.
964 =head2 Multiple Moves
966 Be careful when issueing move_* methods to multiple objects. If
967 you've pre-loaded the objects then when you move one of the objects
968 the position of the other object will not reflect their new value
969 until you reload them from the database - see
970 L<DBIx::Class::Row/discard_changes>.
972 There are times when you will want to move objects as groups, such
973 as changeing the parent of several objects at once - this directly
974 conflicts with this problem. One solution is for us to write a
975 ResultSet class that supports a parent() method, for example. Another
976 solution is to somehow automagically modify the objects that exist
977 in the current object's result set to have the new position value.
979 =head2 Default Values
981 Using a database defined default_value on one of your group columns
982 could result in the position not being assigned correctly.
986 Original code framework
987 Aran Deltac <bluefeet@cpan.org>
989 Constraints support and code generalisation
990 Peter Rabbitson <ribasushi@cpan.org>
994 You may distribute this code under the same terms as Perl itself.