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
366 # we need to null-position the moved row if the position column is part of a constraint
367 if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $self->result_source->unique_constraints }} ) ) ) {
368 $self->_ordered_internal_update({ $position_column => $self->null_position_value });
371 $self->_shift_siblings ($direction, @between);
372 $self->_ordered_internal_update({ $position_column => $new_pos_val });
380 $item->move_to_group( $group, $position );
382 Moves the object to the specified position of the specified
383 group, or to the end of the group if $position is undef.
384 1 is returned on success, and 0 is returned if the object is
385 already at the specified position of the specified group.
387 $group may be specified as a single scalar if only one
388 grouping column is in use, or as a hashref of column => value pairs
389 if multiple grouping columns are in use.
394 my( $self, $to_group, $to_position ) = @_;
396 $self->throw_exception ('move_to_group() expects a group specification')
397 unless defined $to_group;
399 # if we're given a string, turn it into a hashref
400 unless (ref $to_group eq 'HASH') {
401 my @gcols = $self->_grouping_columns;
403 $self->throw_exception ('Single group supplied for a multi-column group identifier') if @gcols > 1;
404 $to_group = {$gcols[0] => $to_group};
407 my $position_column = $self->position_column;
409 return 0 if ( defined($to_position) and $to_position < 1 );
410 if ($self->_is_in_group ($to_group) ) {
411 return 0 if not defined $to_position;
412 return $self->move_to ($to_position);
415 # FIXME this needs to be wrapped in a transaction
417 # Move to end of current group to adjust siblings
420 $self->set_inflated_columns({ %$to_group, $position_column => undef });
421 my $new_group_count = $self->_group_rs->count;
423 if ( not defined($to_position) or $to_position > $new_group_count) {
425 $position_column => $new_group_count
426 ? $self->_next_position_value ( $self->last_sibling->get_column ($position_column) ) # FIXME - no need to inflate last_sibling
427 : $self->_initial_position_value
431 my $bumped_pos_val = $self->_position_value ($to_position);
432 my @between = ($to_position, $new_group_count);
433 $self->_shift_siblings (1, @between); #shift right
434 $self->set_column( $position_column => $bumped_pos_val );
437 $self->_ordered_internal_update;
445 Overrides the DBIC insert() method by providing a default
446 position number. The default will be the number of rows in
447 the table +1, thus positioning the new record at the last position.
453 my $position_column = $self->position_column;
455 unless ($self->get_column($position_column)) {
456 my $lsib = $self->last_sibling; # FIXME - no need to inflate last_sibling
458 $position_column => ($lsib
459 ? $self->_next_position_value ( $lsib->get_column ($position_column) )
460 : $self->_initial_position_value
465 return $self->next::method( @_ );
470 Overrides the DBIC update() method by checking for a change
471 to the position and/or group columns. Movement within a
472 group or to another group is handled by repositioning
473 the appropriate siblings. Position defaults to the end
474 of a new group if it has been changed to undef.
481 # this is set by _ordered_internal_update()
482 return $self->next::method(@_) if $self->{_ORDERED_INTERNAL_UPDATE};
485 $self->set_inflated_columns($upd) if $upd;
486 my %changes = $self->get_dirty_columns;
487 $self->discard_changes;
489 my $position_column = $self->position_column;
491 # if nothing group/position related changed - short circuit
492 if (not grep { exists $changes{$_} } ($self->_grouping_columns, $position_column) ) {
493 return $self->next::method( \%changes, @_ );
496 # FIXME this needs to be wrapped in a transaction
498 # if any of our grouping columns have been changed
499 if (grep { exists $changes{$_} } ($self->_grouping_columns) ) {
501 # create new_group by taking the current group and inserting changes
502 my $new_group = {$self->_grouping_clause};
503 foreach my $col (keys %$new_group) {
504 if (exists $changes{$col}) {
505 $new_group->{$col} = delete $changes{$col}; # don't want to pass this on to next::method
509 $self->move_to_group(
511 (exists $changes{$position_column}
512 # The FIXME bit contradicts the documentation: when changing groups without supplying explicit
513 # positions in move_to_group(), we push the item to the end of the group.
514 # However when I was rewriting this, the position from the old group was clearly passed to the new one
515 # Probably needs to go away (by ribasushi)
516 ? delete $changes{$position_column} # means there was a position change supplied with the update too
517 : $self->_position # FIXME!
521 elsif (exists $changes{$position_column}) {
522 $self->move_to(delete $changes{$position_column});
525 return $self->next::method( \%changes, @_ );
531 Overrides the DBIC delete() method by first moving the object
532 to the last position, then deleting it, thus ensuring the
533 integrity of the positions.
539 # FIXME this needs to be wrapped in a transaction
542 return $self->next::method( @_ );
546 =head1 METHODS FOR EXTENDING ORDERED
548 You would want to override the methods below if you use sparse
549 (non-linear) or non-numeric position values. This can be useful
550 if you are working with preexisting non-normalised position data,
551 or if you need to work with materialized path columns.
555 my $num_pos = $item->_position;
557 Returns the B<absolute numeric position> of the current object, with the
558 first object being at position 1, its sibling at position 2 and so on.
559 By default simply returns the value of L</position_column>.
565 # #the right way to do this
566 # return $self->previous_siblings->count + 1;
568 return $self->get_column ($self->position_column);
571 =head2 _position_value
573 my $pos_value = $item->_position_value ( $pos )
575 Returns the B<value> of L</position_column> of the object at numeric
576 position C<$pos>. By default simply returns C<$pos>.
579 sub _position_value {
580 my ($self, $pos) = @_;
582 # #the right way to do this (not optimized)
583 # my $position_column = $self->position_column;
584 # return $self -> _group_rs
585 # -> search({}, { order_by => $position_column })
586 # -> slice ( $pos - 1)
588 # -> get_column ($position_column);
593 =head2 _initial_position_value
595 __PACKAGE__->_initial_position_value(0);
597 This method specifies a B<value> of L</position_column> which is assigned
598 to the first inserted element of a group, if no value was supplied at
599 insertion time. All subsequent values are derived from this one by
600 L</_next_position_value> below. Defaults to 1.
604 __PACKAGE__->mk_classdata( '_initial_position_value' => 1 );
606 =head2 _next_position_value
608 my $new_value = $item->_next_position_value ( $position_value )
610 Returns a position B<value> that would be considered C<next> with
611 regards to C<$position_value>. Can be pretty much anything, given
612 that C<< $position_value < $new_value >> where C<< < >> is the
613 SQL comparison operator (usually works fine on strings). The
614 default method expects C<$position_value> to be numeric, and
615 returns C<$position_value + 1>
618 sub _next_position_value {
622 =head2 _shift_siblings
624 $item->_shift_siblings ($direction, @between)
626 Shifts all siblings with B<positions values> in the range @between
627 (inclusive) by one position as specified by $direction (left if < 0,
628 right if > 0). By default simply increments/decrements each
629 L<position_column> value by 1, doing so in a way as to not violate
630 any existing constraints.
632 Note that if you override this method and have unique constraints
633 including the L<position_column> the shift is not a trivial task.
634 Refer to the implementation source of the default method for more
638 sub _shift_siblings {
639 my ($self, $direction, @between) = @_;
640 return 0 unless $direction;
642 my $position_column = $self->position_column;
645 if ($direction < 0) {
654 my $shift_rs = $self->_group_rs-> search ({ $position_column => { -between => \@between } });
656 # some databases (sqlite) are dumb and can not do a blanket
657 # increment/decrement. So what we do here is check if the
658 # position column is part of a unique constraint, and do a
659 # one-by-one update if this is the case
661 if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $self->result_source->unique_constraints }} ) ) ) {
663 my $rs = $shift_rs->search ({}, { order_by => { "-$ord", $position_column } } );
664 # FIXME - no need to inflate each row
665 while (my $r = $rs->next) {
666 $r->_ordered_internal_update ({ $position_column => \ "$position_column $op 1" } );
670 $shift_rs->update ({ $position_column => \ "$position_column $op 1" } );
674 =head1 PRIVATE METHODS
676 These methods are used internally. You should never have the
681 This method returns a resultset containing all members of the row
682 group (including the row itself).
687 return $self->result_source->resultset->search({$self->_grouping_clause()});
692 Returns an unordered resultset of all objects in the same group
693 excluding the object you called this method on.
698 my $position_column = $self->position_column;
699 return $self->_group_rs->search(
700 { $position_column => { '!=' => $self->get_column($position_column) } },
704 =head2 _grouping_clause
706 This method returns one or more name=>value pairs for limiting a search
707 by the grouping column(s). If the grouping column is not
708 defined then this will return an empty list.
711 sub _grouping_clause {
713 return map { $_ => $self->get_column($_) } $self->_grouping_columns();
716 =head2 _get_grouping_columns
718 Returns a list of the column names used for grouping, regardless of whether
719 they were specified as an arrayref or a single string, and returns ()
720 if there is no grouping.
723 sub _grouping_columns {
725 my $col = $self->grouping_column();
726 if (ref $col eq 'ARRAY') {
737 $item->_is_in_group( {user => 'fred', list => 'work'} )
739 Returns true if the object is in the group represented by hashref $other
743 my ($self, $other) = @_;
744 my $current = {$self->_grouping_clause};
746 no warnings qw/uninitialized/;
749 join ("\x00", sort keys %$current)
751 join ("\x00", sort keys %$other)
753 for my $key (keys %$current) {
754 return 0 if $current->{$key} ne $other->{$key};
759 =head2 _ordered_internal_update
761 This is a short-circuited method, that is used internally by this
762 module to update positioning values in isolation (i.e. without
763 triggering any of the positioning integrity code).
765 Some day you might get confronted by datasets that have ambiguous
766 positioning data (i.e. duplicate position values within the same group,
767 in a table without unique constraints). When manually fixing such data
768 keep in mind that you can not invoke L<DBIx::Class::Row/update> like
769 you normally would, as it will get confused by the wrong data before
770 having a chance to update the ill-defined row. If you really know what
771 you are doing use this method which bypasses any hooks introduced by
776 sub _ordered_internal_update {
778 local $self->{_ORDERED_INTERNAL_UPDATE} = 1;
779 return $self->update (@_);
788 =head2 Race Condition on Insert
790 If a position is not specified for an insert than a position
791 will be chosen based either on L</_initial_position_value> or
792 L</_next_position_value>, depending if there are already some
793 items in the current group. The space of time between the
794 necessary selects and insert introduces a race condition.
795 Having unique constraints on your position/group columns,
796 and using transactions (see L<DBIx::Class::Storage/txn_do>)
797 will prevent such race conditions going undetected.
799 =head2 Multiple Moves
801 Be careful when issueing move_* methods to multiple objects. If
802 you've pre-loaded the objects then when you move one of the objects
803 the position of the other object will not reflect their new value
804 until you reload them from the database - see
805 L<DBIx::Class::Row/discard_changes>.
807 There are times when you will want to move objects as groups, such
808 as changeing the parent of several objects at once - this directly
809 conflicts with this problem. One solution is for us to write a
810 ResultSet class that supports a parent() method, for example. Another
811 solution is to somehow automagically modify the objects that exist
812 in the current object's result set to have the new position value.
814 =head2 Default Values
816 Using a database defined default_value on one of your group columns
817 could result in the position not being assigned correctly.
821 Aran Deltac <bluefeet@cpan.org>
825 You may distribute this code under the same terms as Perl itself.