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;
277 $item->move_previous();
279 Swaps position with the sibling in the position previous in
280 the list. Returns 1 on success, and 0 if the object is
281 already the first one.
287 return $self->move_to ($self->_position - 1);
294 Swaps position with the sibling in the next position in the
295 list. Returns 1 on success, and 0 if the object is already
296 the last in the list.
302 return 0 unless $self->next_siblings->count;
303 return $self->move_to ($self->_position + 1);
310 Moves the object to the first position in the list. Returns 1
311 on success, and 0 if the object is already the first.
316 return shift->move_to( 1 );
323 Moves the object to the last position in the list. Returns 1
324 on success, and 0 if the object is already the last one.
330 return $self->move_to( $self->_group_rs->count );
335 $item->move_to( $position );
337 Moves the object to the specified position. Returns 1 on
338 success, and 0 if the object is already at the specified
344 my( $self, $to_position ) = @_;
345 return 0 if ( $to_position < 1 );
347 my $from_position = $self->_position;
348 return 0 if ( $from_position == $to_position );
350 my $position_column = $self->position_column;
352 # FIXME this needs to be wrapped in a transaction
354 my ($direction, @between);
355 if ( $from_position < $to_position ) {
357 @between = map { $self->_position_value ($_) } ( $from_position + 1, $to_position );
361 @between = map { $self->_position_value ($_) } ( $to_position, $from_position - 1 );
364 my $new_pos_val = $self->_position_value ($to_position); # record this before the shift
365 $self->_ordered_internal_update({ $position_column => $self->null_position_value }); # take the row out of the picture for a bit
366 $self->_shift_siblings ($direction, @between);
367 $self->_ordered_internal_update({ $position_column => $new_pos_val });
375 $item->move_to_group( $group, $position );
377 Moves the object to the specified position of the specified
378 group, or to the end of the group if $position is undef.
379 1 is returned on success, and 0 is returned if the object is
380 already at the specified position of the specified group.
382 $group may be specified as a single scalar if only one
383 grouping column is in use, or as a hashref of column => value pairs
384 if multiple grouping columns are in use.
389 my( $self, $to_group, $to_position ) = @_;
391 $self->throw_exception ('move_to_group() expects a group specification')
392 unless defined $to_group;
394 # if we're given a string, turn it into a hashref
395 unless (ref $to_group eq 'HASH') {
396 my @gcols = $self->_grouping_columns;
398 $self->throw_exception ('Single group supplied for a multi-column group identifier') if @gcols > 1;
399 $to_group = {$gcols[0] => $to_group};
402 my $position_column = $self->position_column;
404 return 0 if ( defined($to_position) and $to_position < 1 );
405 if ($self->_is_in_group ($to_group) ) {
406 return 0 if not defined $to_position;
407 return $self->move_to ($to_position);
410 # FIXME this needs to be wrapped in a transaction
412 # Move to end of current group to adjust siblings
415 $self->set_inflated_columns({ %$to_group, $position_column => undef });
416 my $new_group_count = $self->_group_rs->count;
418 if ( not defined($to_position) or $to_position > $new_group_count) {
420 $position_column => $new_group_count
421 ? $self->_next_position_value ( $self->last_sibling->get_column ($position_column) ) # FIXME - no need to inflate last_sibling
422 : $self->_initial_position_value
426 my $bumped_pos_val = $self->_position_value ($to_position);
427 my @between = ($to_position, $new_group_count);
428 $self->_shift_siblings (1, @between); #shift right
429 $self->set_column( $position_column => $bumped_pos_val );
432 $self->_ordered_internal_update;
440 Overrides the DBIC insert() method by providing a default
441 position number. The default will be the number of rows in
442 the table +1, thus positioning the new record at the last position.
448 my $position_column = $self->position_column;
450 unless ($self->get_column($position_column)) {
451 my $lsib = $self->last_sibling; # FIXME - no need to inflate last_sibling
453 $position_column => ($lsib
454 ? $self->_next_position_value ( $lsib->get_column ($position_column) )
455 : $self->_initial_position_value
460 return $self->next::method( @_ );
465 Overrides the DBIC update() method by checking for a change
466 to the position and/or group columns. Movement within a
467 group or to another group is handled by repositioning
468 the appropriate siblings. Position defaults to the end
469 of a new group if it has been changed to undef.
476 # this is set by _ordered_internal_update()
477 return $self->next::method(@_) if $self->{_ORDERED_INTERNAL_UPDATE};
480 $self->set_inflated_columns($upd) if $upd;
481 my %changes = $self->get_dirty_columns;
482 $self->discard_changes;
484 my $position_column = $self->position_column;
486 # if nothing group/position related changed - short circuit
487 if (not grep { exists $changes{$_} } ($self->_grouping_columns, $position_column) ) {
488 return $self->next::method( \%changes, @_ );
491 # FIXME this needs to be wrapped in a transaction
493 # if any of our grouping columns have been changed
494 if (grep { exists $changes{$_} } ($self->_grouping_columns) ) {
496 # create new_group by taking the current group and inserting changes
497 my $new_group = {$self->_grouping_clause};
498 foreach my $col (keys %$new_group) {
499 if (exists $changes{$col}) {
500 $new_group->{$col} = delete $changes{$col}; # don't want to pass this on to next::method
504 $self->move_to_group(
506 (exists $changes{$position_column}
507 # The FIXME bit contradicts the documentation: when changing groups without supplying explicit
508 # positions in move_to_group(), we push the item to the end of the group.
509 # However when I was rewriting this, the position from the old group was clearly passed to the new one
510 # Probably needs to go away (by ribasushi)
511 ? delete $changes{$position_column} # means there was a position change supplied with the update too
512 : $self->_position # FIXME!
516 elsif (exists $changes{$position_column}) {
517 $self->move_to(delete $changes{$position_column});
520 return $self->next::method( \%changes, @_ );
526 Overrides the DBIC delete() method by first moving the object
527 to the last position, then deleting it, thus ensuring the
528 integrity of the positions.
534 # FIXME this needs to be wrapped in a transaction
537 return $self->next::method( @_ );
541 =head1 Methods for extending Ordered
543 You would want to override the methods below if you use sparse
544 (non-linear) or non-numeric position values. This can be useful
545 if you are working with preexisting non-normalised position data,
546 or if you need to work with materialized path columns.
550 my $num_pos = $item->_position;
552 Returns the absolute numeric position of the current object, with the
553 first object being at position 1, its sibling at position 2 and so on.
554 By default simply returns the value of L</position_column>.
560 # #the right way to do this
561 # return $self->previous_siblings->count + 1;
563 return $self->get_column ($self->position_column);
566 =head2 _position_value
568 my $pos_value = $item->_position_value ( $pos )
570 Returns the value of L</position_column> of the object at numeric
571 position C<$pos>. By default simply returns C<$pos>.
574 sub _position_value {
575 my ($self, $pos) = @_;
577 # #the right way to do this (not optimized)
578 # my $position_column = $self->position_column;
579 # return $self -> _group_rs
580 # -> search({}, { order_by => $position_column })
581 # -> slice ( $pos - 1)
583 # -> get_column ($position_column);
588 =head2 _initial_position_value
590 __PACKAGE__->_initial_position_value(0);
592 This method specifies a value of L</position_column> which is assigned
593 to the first inserted element of a group, if no value was supplied at
594 insertion time. All subsequent values are derived from this one by
595 L</_next_position_value> below. Defaults to 1.
599 __PACKAGE__->mk_classdata( '_initial_position_value' => 1 );
601 =head2 _next_position_value
603 my $new_value = $item->_next_position_value ( $position_value )
605 Returns a position value that would be considered C<next> with
606 regards to C<$position_value>. Can be pretty much anything, given
607 that C<< $position_value < $new_value >> where C<< < >> is the
608 SQL comparison operator (usually works fine on strings). The
609 default method expects C<$position_value> to be numeric, and
610 returns C<$position_value + 1>
613 sub _next_position_value {
617 =head2 _shift_siblings
619 $item->_shift_siblings ($direction, @between)
621 Shifts all siblings with position in the range @between (inclusive)
622 by one position as specified by $direction (left if < 0, right if > 0).
623 By default simply increments/decrements each L<position_column> value
627 sub _shift_siblings {
628 my ($self, $direction, @between) = @_;
629 return 0 unless $direction;
631 my $position_column = $self->position_column;
634 if ($direction < 0) {
643 my $shift_rs = $self->_group_rs-> search ({ $position_column => { -between => \@between } });
645 # some databases (sqlite) are dumb and can not do a blanket
646 # increment/decrement. So what we do here is check if the
647 # position column is part of a unique constraint, and do a
648 # one-by-one update if this is the case
650 my %uc = $self->result_source->unique_constraints;
651 if (grep { $_ eq $position_column } ( map { @$_ } (values %uc) ) ) {
653 my $rs = $shift_rs->search ({}, { order_by => { "-$ord", $position_column } } );
654 # FIXME - no need to inflate each row
655 while (my $r = $rs->next) {
656 $r->_ordered_internal_update ({ $position_column => \ "$position_column $op 1" } );
660 $shift_rs->update ({ $position_column => \ "$position_column $op 1" } );
664 =head1 PRIVATE METHODS
666 These methods are used internally. You should never have the
671 This method returns a resultset containing all memebers of the row
672 group (including the row itself).
677 return $self->result_source->resultset->search({$self->_grouping_clause()});
682 Returns an unordered resultset of all objects in the same group
683 excluding the object you called this method on.
688 my $position_column = $self->position_column;
689 return $self->_group_rs->search(
690 { $position_column => { '!=' => $self->get_column($position_column) } },
694 =head2 _grouping_clause
696 This method returns one or more name=>value pairs for limiting a search
697 by the grouping column(s). If the grouping column is not
698 defined then this will return an empty list.
701 sub _grouping_clause {
703 return map { $_ => $self->get_column($_) } $self->_grouping_columns();
706 =head2 _get_grouping_columns
708 Returns a list of the column names used for grouping, regardless of whether
709 they were specified as an arrayref or a single string, and returns ()
710 if there is no grouping.
713 sub _grouping_columns {
715 my $col = $self->grouping_column();
716 if (ref $col eq 'ARRAY') {
727 $item->_is_in_group( {user => 'fred', list => 'work'} )
729 Returns true if the object is in the group represented by hashref $other
733 my ($self, $other) = @_;
734 my $current = {$self->_grouping_clause};
736 no warnings qw/uninitialized/;
739 join ("\x00", sort keys %$current)
741 join ("\x00", sort keys %$other)
743 for my $key (keys %$current) {
744 return 0 if $current->{$key} ne $other->{$key};
749 sub _ordered_internal_update {
751 local $self->{_ORDERED_INTERNAL_UPDATE} = 1;
752 return $self->update (@_);
761 =head2 Race Condition on Insert
763 If a position is not specified for an insert than a position
764 will be chosen based either on L</_initial_position_value> or
765 L</_next_position_value>, depending if there are already some
766 items in the current group. The space of time between the
767 necessary selects and insert introduces a race condition.
768 Having unique constraints on your position/group columns,
769 and using transactions (see L<DBIx::Class::Storage/txn_do>)
770 will prevent such race conditions going undetected.
772 =head2 Multiple Moves
774 Be careful when issueing move_* methods to multiple objects. If
775 you've pre-loaded the objects then when you move one of the objects
776 the position of the other object will not reflect their new value
777 until you reload them from the database - see
778 L<DBIx::Class::Row/discard_changes>.
780 There are times when you will want to move objects as groups, such
781 as changeing the parent of several objects at once - this directly
782 conflicts with this problem. One solution is for us to write a
783 ResultSet class that supports a parent() method, for example. Another
784 solution is to somehow automagically modify the objects that exist
785 in the current object's result set to have the new position value.
789 Aran Deltac <bluefeet@cpan.org>
793 You may distribute this code under the same terms as Perl itself.