ed726dee1bb5e55aca853926a5d446ed7dfec203
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / Ordered.pm
1 package DBIx::Class::Ordered;
2 use strict;
3 use warnings;
4 use base qw( DBIx::Class );
5
6 =head1 NAME
7
8 DBIx::Class::Ordered - Modify the position of objects in an ordered list.
9
10 =head1 SYNOPSIS
11
12 Create a table for your ordered data.
13
14   CREATE TABLE items (
15     item_id INTEGER PRIMARY KEY AUTOINCREMENT,
16     name TEXT NOT NULL,
17     position INTEGER NOT NULL
18   );
19
20 Optionally, add one or more columns to specify groupings, allowing you 
21 to maintain independent ordered lists within one table:
22
23   CREATE TABLE items (
24     item_id INTEGER PRIMARY KEY AUTOINCREMENT,
25     name TEXT NOT NULL,
26     position INTEGER NOT NULL,
27     group_id INTEGER NOT NULL
28   );
29
30 Or even
31
32   CREATE TABLE items (
33     item_id INTEGER PRIMARY KEY AUTOINCREMENT,
34     name TEXT NOT NULL,
35     position INTEGER NOT NULL,
36     group_id INTEGER NOT NULL,
37     other_group_id INTEGER NOT NULL
38   );
39
40 In your Schema or DB class add "Ordered" to the top 
41 of the component list.
42
43   __PACKAGE__->load_components(qw( Ordered ... ));
44
45 Specify the column that stores the position number for 
46 each row.
47
48   package My::Item;
49   __PACKAGE__->position_column('position');
50
51 If you are using one grouping column, specify it as follows:
52
53   __PACKAGE__->grouping_column('group_id');
54
55 Or if you have multiple grouping columns:
56
57   __PACKAGE__->grouping_column(['group_id', 'other_group_id']);
58
59 That's it, now you can change the position of your objects.
60
61   #!/use/bin/perl
62   use My::Item;
63
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 });
67
68   my $rs = $item->siblings();
69   my @siblings = $item->siblings();
70
71   my $sibling;
72   $sibling = $item->first_sibling();
73   $sibling = $item->last_sibling();
74   $sibling = $item->previous_sibling();
75   $sibling = $item->next_sibling();
76
77   $item->move_previous();
78   $item->move_next();
79   $item->move_first();
80   $item->move_last();
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 );
86
87 =head1 DESCRIPTION
88
89 This module provides a simple interface for modifying the ordered 
90 position of DBIx::Class objects.
91
92 =head1 AUTO UPDATE
93
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.
97
98 =head1 METHODS
99
100 =head2 position_column
101
102   __PACKAGE__->position_column('position');
103
104 Sets and retrieves the name of the column that stores the 
105 positional value of each record.  Defaults to "position".
106
107 =cut
108
109 __PACKAGE__->mk_classdata( 'position_column' => 'position' );
110
111 =head2 grouping_column
112
113   __PACKAGE__->grouping_column('group_id');
114
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.
118
119 =cut
120
121 __PACKAGE__->mk_classdata( 'grouping_column' );
122
123 =head2 null_position_value
124
125   __PACKAGE__->null_position_value(undef);
126
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
132 indeed start from 0.
133
134 =cut
135
136 __PACKAGE__->mk_classdata( 'null_position_value' => 0 );
137
138 =head2 siblings
139
140   my $rs = $item->siblings();
141   my @siblings = $item->siblings();
142
143 Returns an B<ordered> resultset of all other objects in the same
144 group excluding the one you called it on.
145
146 The ordering is a backwards-compatibility artifact - if you need
147 a resultset with no ordering applied use L</_siblings>
148
149 =cut
150 sub siblings {
151     my $self = shift;
152     return $self->_siblings->search ({}, { order_by => $self->position_column } );
153 }
154
155 =head2 previous_siblings
156
157   my $prev_rs = $item->previous_siblings();
158   my @prev_siblings = $item->previous_siblings();
159
160 Returns a resultset of all objects in the same group
161 positioned before the object on which this method was called.
162
163 =cut
164 sub previous_siblings {
165     my $self = shift;
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 } })
170         : $self->_siblings
171     );
172 }
173
174 =head2 next_siblings
175
176   my $next_rs = $item->next_siblings();
177   my @next_siblings = $item->next_siblings();
178
179 Returns a resultset of all objects in the same group
180 positioned after the object on which this method was called.
181
182 =cut
183 sub next_siblings {
184     my $self = shift;
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 } })
189         : $self->_siblings
190     );
191 }
192
193 =head2 previous_sibling
194
195   my $sibling = $item->previous_sibling();
196
197 Returns the sibling that resides one position back.  Returns 0
198 if the current object is the first one.
199
200 =cut
201
202 sub previous_sibling {
203     my $self = shift;
204     my $position_column = $self->position_column;
205
206     my $psib = $self->previous_siblings->search(
207         {},
208         { rows => 1, order_by => { '-desc' => $position_column } },
209     )->single;
210
211     return defined $psib ? $psib : 0;
212 }
213
214 =head2 first_sibling
215
216   my $sibling = $item->first_sibling();
217
218 Returns the first sibling object, or 0 if the first sibling 
219 is this sibling.
220
221 =cut
222
223 sub first_sibling {
224     my $self = shift;
225     my $position_column = $self->position_column;
226
227     my $fsib = $self->previous_siblings->search(
228         {},
229         { rows => 1, order_by => { '-asc' => $position_column } },
230     )->single;
231
232     return defined $fsib ? $fsib : 0;
233 }
234
235 =head2 next_sibling
236
237   my $sibling = $item->next_sibling();
238
239 Returns the sibling that resides one position forward. Returns 0
240 if the current object is the last one.
241
242 =cut
243
244 sub next_sibling {
245     my $self = shift;
246     my $position_column = $self->position_column;
247     my $nsib = $self->next_siblings->search(
248         {},
249         { rows => 1, order_by => { '-asc' => $position_column } },
250     )->single;
251
252     return defined $nsib ? $nsib : 0;
253 }
254
255 =head2 last_sibling
256
257   my $sibling = $item->last_sibling();
258
259 Returns the last sibling, or 0 if the last sibling is this 
260 sibling.
261
262 =cut
263
264 sub last_sibling {
265     my $self = shift;
266     my $position_column = $self->position_column;
267     my $lsib = $self->next_siblings->search(
268         {},
269         { rows => 1, order_by => { '-desc' => $position_column } },
270     )->single;
271
272     return defined $lsib ? $lsib : 0;
273 }
274
275 # an optimized method to get the last sibling position value without inflating a row object
276 sub _last_sibling_posval {
277     my $self = shift;
278     my $position_column = $self->position_column;
279
280     my $cursor = $self->next_siblings->search(
281         {},
282         { rows => 1, order_by => { '-desc' => $position_column }, select => $position_column },
283     )->cursor;
284
285     my ($pos) = $cursor->next;
286     return $pos;
287 }
288
289 =head2 move_previous
290
291   $item->move_previous();
292
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.
296
297 =cut
298
299 sub move_previous {
300     my $self = shift;
301     return $self->move_to ($self->_position - 1);
302 }
303
304 =head2 move_next
305
306   $item->move_next();
307
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.
311
312 =cut
313
314 sub move_next {
315     my $self = shift;
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);
318 }
319
320 =head2 move_first
321
322   $item->move_first();
323
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.
326
327 =cut
328
329 sub move_first {
330     return shift->move_to( 1 );
331 }
332
333 =head2 move_last
334
335   $item->move_last();
336
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.
339
340 =cut
341
342 sub move_last {
343     my $self = shift;
344     my $last_posval = $self->_last_sibling_posval;
345
346     return 0 unless defined $last_posval;
347
348     return $self->move_to( $self->_position_from_value ($last_posval) );
349 }
350
351 =head2 move_to
352
353   $item->move_to( $position );
354
355 Moves the object to the specified position.  Returns 1 on
356 success, and 0 if the object is already at the specified
357 position.
358
359 =cut
360
361 sub move_to {
362     my( $self, $to_position ) = @_;
363     return 0 if ( $to_position < 1 );
364
365     my $position_column = $self->position_column;
366
367     my $guard;
368
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)
373
374       $guard = $self->result_source->schema->txn_scope_guard;
375
376       my $cursor = $self->result_source->resultset->search(
377         $self->ident_condition,
378         { select => $position_column },
379       )->cursor;
380
381       my ($pos) = $cursor->next;
382       $self->$position_column ($pos);
383       delete $self->{_dirty_columns}{$position_column};
384     }
385
386     my $from_position = $self->_position;
387
388     if ( $from_position == $to_position ) {   # FIXME this will not work for non-numeric order
389       $guard->commit if $guard;
390       return 0;
391     }
392
393     $guard ||= $self->result_source->schema->txn_scope_guard;
394
395     my ($direction, @between);
396     if ( $from_position < $to_position ) {
397       $direction = -1;
398       @between = map { $self->_position_value ($_) } ( $from_position + 1, $to_position );
399     }
400     else {
401       $direction = 1;
402       @between = map { $self->_position_value ($_) } ( $to_position, $from_position - 1 );
403     }
404
405     my $new_pos_val = $self->_position_value ($to_position);  # record this before the shift
406
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 });
410     }
411
412     $self->_shift_siblings ($direction, @between);
413     $self->_ordered_internal_update({ $position_column => $new_pos_val });
414
415     $guard->commit;
416     return 1;
417 }
418
419 =head2 move_to_group
420
421   $item->move_to_group( $group, $position );
422
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.
427
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.
431
432 =cut
433
434 sub move_to_group {
435     my( $self, $to_group, $to_position ) = @_;
436
437     $self->throw_exception ('move_to_group() expects a group specification')
438         unless defined $to_group;
439
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;
443
444         $self->throw_exception ('Single group supplied for a multi-column group identifier') if @gcols > 1;
445         $to_group = {$gcols[0] => $to_group};
446     }
447
448     my $position_column = $self->position_column;
449
450     return 0 if ( defined($to_position) and $to_position < 1 );
451
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 ($_);
459     }
460
461     # re-query only the dirty columns, and restore them on the
462     # object (subsequent code will update them to the correct
463     # after-move values)
464     if (@dirty_cols) {
465       $guard = $self->result_source->schema->txn_scope_guard;
466
467       my $cursor = $self->result_source->resultset->search(
468         $self->ident_condition,
469         { select => \@dirty_cols },
470       )->cursor;
471
472       my @original_values = $cursor->next;
473       $self->set_inflated_columns ({ %values, map { $_ => shift @original_values } (@dirty_cols) });
474       delete $self->{_dirty_columns}{$_} for (@dirty_cols);
475     }
476
477     if ($self->_is_in_group ($to_group) ) {
478       my $ret;
479       if (defined $to_position) {
480         $ret = $self->move_to ($to_position);
481       }
482
483       $guard->commit if $guard;
484       return $ret||0;
485     }
486
487     $guard ||= $self->result_source->schema->txn_scope_guard;
488
489     # Move to end of current group to adjust siblings
490     $self->move_last;
491
492     $self->set_inflated_columns({ %$to_group, $position_column => undef });
493     my $new_group_last_posval = $self->_last_sibling_posval;
494     my $new_group_last_position = $self->_position_from_value (
495       $new_group_last_posval
496     );
497
498     if ( not defined($to_position) or $to_position > $new_group_last_position) {
499       $self->set_column(
500         $position_column => $new_group_last_position
501           ? $self->_next_position_value ( $new_group_last_posval )
502           : $self->_initial_position_value
503       );
504     }
505     else {
506       my $bumped_pos_val = $self->_position_value ($to_position);
507       my @between = ($to_position, $new_group_last_position);
508       $self->_shift_siblings (1, @between);   #shift right
509       $self->set_column( $position_column => $bumped_pos_val );
510     }
511
512     $self->_ordered_internal_update;
513
514     $guard->commit;
515
516     return 1;
517 }
518
519 =head2 insert
520
521 Overrides the DBIC insert() method by providing a default 
522 position number.  The default will be the number of rows in 
523 the table +1, thus positioning the new record at the last position.
524
525 =cut
526
527 sub insert {
528     my $self = shift;
529     my $position_column = $self->position_column;
530
531     unless ($self->get_column($position_column)) {
532         my $lsib_posval = $self->_last_sibling_posval;
533         $self->set_column(
534             $position_column => (defined $lsib_posval
535                 ? $self->_next_position_value ( $lsib_posval )
536                 : $self->_initial_position_value
537             )
538         );
539     }
540
541     return $self->next::method( @_ );
542 }
543
544 =head2 update
545
546 Overrides the DBIC update() method by checking for a change
547 to the position and/or group columns.  Movement within a
548 group or to another group is handled by repositioning
549 the appropriate siblings.  Position defaults to the end
550 of a new group if it has been changed to undef.
551
552 =cut
553
554 sub update {
555     my $self = shift;
556
557     # this is set by _ordered_internal_update()
558     return $self->next::method(@_) if $self->{_ORDERED_INTERNAL_UPDATE};
559
560     my $position_column = $self->position_column;
561     my @ordering_columns = ($self->_grouping_columns, $position_column);
562
563
564     # these steps are necessary to keep the external appearance of
565     # ->update($upd) so that other things overloading update() will
566     # work properly
567     my %original_values = $self->get_inflated_columns;
568     my %existing_changes = $self->get_dirty_columns;
569
570     # See if any of the *supplied* changes would affect the ordering
571     # The reason this is so contrived, is that we want to leverage
572     # the datatype aware value comparing, while at the same time
573     # keep the original value intact (it will be updated later by the
574     # corresponding routine)
575
576     my %upd = %{shift || {}};
577     my %changes = %existing_changes;
578
579     for (@ordering_columns) {
580         next unless exists $upd{$_};
581
582         # we do not want to keep propagating this to next::method
583         # as it will be a done deal by the time get there
584         my $value = delete $upd{$_};
585         $self->set_inflated_columns ({ $_ => $value });
586
587         # see if an update resulted in a dirty column
588         # it is important to preserve the old value, as it
589         # will be needed to carry on a successfull move()
590         # operation without re-querying the database
591         if ($self->is_column_changed ($_) && not exists $existing_changes{$_}) {
592             $changes{$_} = $value;
593             $self->set_inflated_columns ({ $_ => $original_values{$_} });
594             delete $self->{_dirty_columns}{$_};
595         }
596     }
597
598     # if nothing group/position related changed - short circuit
599     if (not grep { exists $changes{$_} } ( @ordering_columns ) ) {
600         return $self->next::method( \%upd, @_ );
601     }
602
603     {
604         my $guard = $self->result_source->schema->txn_scope_guard;
605
606         # if any of our grouping columns have been changed
607         if (grep { exists $changes{$_} } ($self->_grouping_columns) ) {
608
609             # create new_group by taking the current group and inserting changes
610             my $new_group = {$self->_grouping_clause};
611             foreach my $col (keys %$new_group) {
612                 $new_group->{$col} = $changes{$col} if exists $changes{$col};
613             }
614
615             $self->move_to_group(
616                 $new_group,
617                 (exists $changes{$position_column}
618                     # The FIXME bit contradicts the documentation: POD states that
619                     # when changing groups without supplying explicit positions in
620                     # move_to_group(), we push the item to the end of the group.
621                     # However when I was rewriting this, the position from the old
622                     # group was clearly passed to the new one
623                     # Probably needs to go away (by ribasushi)
624                     ? $changes{$position_column}    # means there was a position change supplied with the update too
625                     : $self->_position              # FIXME! (replace with undef)
626                 ),
627             );
628         }
629         elsif (exists $changes{$position_column}) {
630             $self->move_to($changes{$position_column});
631         }
632
633         my @res;
634         my $want = wantarray();
635         if (not defined $want) {
636             $self->next::method( \%upd, @_ );
637         }
638         elsif ($want) {
639             @res = $self->next::method( \%upd, @_ );
640         }
641         else {
642             $res[0] = $self->next::method( \%upd, @_ );
643         }
644
645         $guard->commit;
646         return $want ? @res : $res[0];
647     }
648 }
649
650 =head2 delete
651
652 Overrides the DBIC delete() method by first moving the object 
653 to the last position, then deleting it, thus ensuring the
654 integrity of the positions.
655
656 =cut
657
658 sub delete {
659     my $self = shift;
660
661     my $guard = $self->result_source->schema->txn_scope_guard;
662
663     $self->move_last;
664
665     my @res;
666     my $want = wantarray();
667     if (not defined $want) {
668         $self->next::method( @_ );
669     }
670     elsif ($want) {
671         @res = $self->next::method( @_ );
672     }
673     else {
674         $res[0] = $self->next::method( @_ );
675     }
676
677     $guard->commit;
678     return $want ? @res : $res[0];
679 }
680
681 =head1 METHODS FOR EXTENDING ORDERED
682
683 You would want to override the methods below if you use sparse
684 (non-linear) or non-numeric position values. This can be useful
685 if you are working with preexisting non-normalised position data,
686 or if you need to work with materialized path columns.
687
688 =head2 _position
689
690   my $num_pos = $item->_position;
691
692 Returns the B<absolute numeric position> of the current object, with the
693 first object being at position 1, its sibling at position 2 and so on.
694 By default simply returns the value of L</position_column>.
695
696 =cut
697 sub _position {
698     my $self = shift;
699
700 #    #the right way to do this
701 #    return $self->previous_siblings->count + 1;
702
703     return $self->get_column ($self->position_column);
704 }
705
706 =head2 _position_from_value
707
708   my $num_pos = $item->_position_of_value ( $pos_value )
709
710 Returns the B<absolute numeric position> of an object with a B<position
711 value> set to C<$pos_value>. By default simply returns C<$pos_value>.
712
713 =cut
714 sub _position_from_value {
715     my ($self, $val) = @_;
716
717     return 0 unless defined $val;
718
719 #    #the right way to do this
720 #    return $self -> _group_rs
721 #                 -> search({ $self->position_column => { '<=', $val } })
722 #                 -> count
723
724     return $val;
725 }
726
727 =head2 _position_value
728
729   my $pos_value = $item->_position_value ( $pos )
730
731 Returns the B<value> of L</position_column> of the object at numeric
732 position C<$pos>. By default simply returns C<$pos>.
733
734 =cut
735 sub _position_value {
736     my ($self, $pos) = @_;
737
738 #    #the right way to do this (not optimized)
739 #    my $position_column = $self->position_column;
740 #    return $self -> _group_rs
741 #                 -> search({}, { order_by => $position_column })
742 #                 -> slice ( $pos - 1)
743 #                 -> single
744 #                 -> get_column ($position_column);
745
746     return $pos;
747 }
748
749 =head2 _initial_position_value
750
751   __PACKAGE__->_initial_position_value(0);
752
753 This method specifies a B<value> of L</position_column> which is assigned
754 to the first inserted element of a group, if no value was supplied at
755 insertion time. All subsequent values are derived from this one by
756 L</_next_position_value> below. Defaults to 1.
757
758 =cut
759
760 __PACKAGE__->mk_classdata( '_initial_position_value' => 1 );
761
762 =head2 _next_position_value
763
764   my $new_value = $item->_next_position_value ( $position_value )
765
766 Returns a position B<value> that would be considered C<next> with
767 regards to C<$position_value>. Can be pretty much anything, given
768 that C<< $position_value < $new_value >> where C<< < >> is the
769 SQL comparison operator (usually works fine on strings). The
770 default method expects C<$position_value> to be numeric, and
771 returns C<$position_value + 1>
772
773 =cut
774 sub _next_position_value {
775     return $_[1] + 1;
776 }
777
778 =head2 _shift_siblings
779
780   $item->_shift_siblings ($direction, @between)
781
782 Shifts all siblings with B<positions values> in the range @between
783 (inclusive) by one position as specified by $direction (left if < 0,
784  right if > 0). By default simply increments/decrements each
785 L<position_column> value by 1, doing so in a way as to not violate
786 any existing constraints.
787
788 Note that if you override this method and have unique constraints
789 including the L<position_column> the shift is not a trivial task.
790 Refer to the implementation source of the default method for more
791 information.
792
793 =cut
794 sub _shift_siblings {
795     my ($self, $direction, @between) = @_;
796     return 0 unless $direction;
797
798     my $position_column = $self->position_column;
799
800     my ($op, $ord);
801     if ($direction < 0) {
802         $op = '-';
803         $ord = 'asc';
804     }
805     else {
806         $op = '+';
807         $ord = 'desc';
808     }
809
810     my $shift_rs = $self->_group_rs-> search ({ $position_column => { -between => \@between } });
811
812     # some databases (sqlite) are dumb and can not do a blanket
813     # increment/decrement. So what we do here is check if the
814     # position column is part of a unique constraint, and do a
815     # one-by-one update if this is the case
816
817     my $rsrc = $self->result_source;
818
819     if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $rsrc->unique_constraints }} ) ) ) {
820
821         my @pcols = $rsrc->primary_columns;
822         my $cursor = $shift_rs->search ({}, { order_by => { "-$ord", $position_column }, columns => \@pcols } )->cursor;
823         my $rs = $self->result_source->resultset;
824
825         while (my @pks = $cursor->next ) {
826
827           my $cond;
828           for my $i (0.. $#pcols) {
829             $cond->{$pcols[$i]} = $pks[$i];
830           }
831
832           $rs->search($cond)->update ({ $position_column => \ "$position_column $op 1" } );
833         }
834     }
835     else {
836         $shift_rs->update ({ $position_column => \ "$position_column $op 1" } );
837     }
838 }
839
840 =head1 PRIVATE METHODS
841
842 These methods are used internally.  You should never have the 
843 need to use them.
844
845 =head2 _group_rs
846
847 This method returns a resultset containing all members of the row
848 group (including the row itself).
849
850 =cut
851 sub _group_rs {
852     my $self = shift;
853     return $self->result_source->resultset->search({$self->_grouping_clause()});
854 }
855
856 =head2 _siblings
857
858 Returns an unordered resultset of all objects in the same group
859 excluding the object you called this method on.
860
861 =cut
862 sub _siblings {
863     my $self = shift;
864     my $position_column = $self->position_column;
865     return $self->_group_rs->search(
866         { $position_column => { '!=' => $self->get_column($position_column) } },
867     );
868 }
869
870 =head2 _grouping_clause
871
872 This method returns one or more name=>value pairs for limiting a search
873 by the grouping column(s).  If the grouping column is not defined then 
874 this will return an empty list.
875
876 =cut
877 sub _grouping_clause {
878     my( $self ) = @_;
879     return map {  $_ => $self->get_column($_)  } $self->_grouping_columns();
880 }
881
882 =head2 _get_grouping_columns
883
884 Returns a list of the column names used for grouping, regardless of whether
885 they were specified as an arrayref or a single string, and returns ()
886 if there is no grouping.
887
888 =cut
889 sub _grouping_columns {
890     my( $self ) = @_;
891     my $col = $self->grouping_column();
892     if (ref $col eq 'ARRAY') {
893         return @$col;
894     } elsif ($col) {
895         return ( $col );
896     } else {
897         return ();
898     }
899 }
900
901 =head2 _is_in_group
902
903     $item->_is_in_group( {user => 'fred', list => 'work'} )
904
905 Returns true if the object is in the group represented by hashref $other
906
907 =cut
908 sub _is_in_group {
909     my ($self, $other) = @_;
910     my $current = {$self->_grouping_clause};
911
912     no warnings qw/uninitialized/;
913
914     return 0 if (
915         join ("\x00", sort keys %$current)
916             ne
917         join ("\x00", sort keys %$other)
918     );
919     for my $key (keys %$current) {
920         return 0 if $current->{$key} ne $other->{$key};
921     }
922     return 1;
923 }
924
925 =head2 _ordered_internal_update
926
927 This is a short-circuited method, that is used internally by this
928 module to update positioning values in isolation (i.e. without
929 triggering any of the positioning integrity code).
930
931 Some day you might get confronted by datasets that have ambiguous
932 positioning data (i.e. duplicate position values within the same group,
933 in a table without unique constraints). When manually fixing such data
934 keep in mind that you can not invoke L<DBIx::Class::Row/update> like
935 you normally would, as it will get confused by the wrong data before
936 having a chance to update the ill-defined row. If you really know what
937 you are doing use this method which bypasses any hooks introduced by
938 this module.
939
940 =cut
941
942 sub _ordered_internal_update {
943     my $self = shift;
944     local $self->{_ORDERED_INTERNAL_UPDATE} = 1;
945     return $self->update (@_);
946 }
947
948 1;
949
950 __END__
951
952 =head1 CAVEATS
953
954 =head2 Race Condition on Insert
955
956 If a position is not specified for an insert than a position 
957 will be chosen based either on L</_initial_position_value> or
958 L</_next_position_value>, depending if there are already some
959 items in the current group. The space of time between the
960 necessary selects and insert introduces a race condition.
961 Having unique constraints on your position/group columns,
962 and using transactions (see L<DBIx::Class::Storage/txn_do>)
963 will prevent such race conditions going undetected.
964
965 =head2 Multiple Moves
966
967 Be careful when issueing move_* methods to multiple objects.  If 
968 you've pre-loaded the objects then when you move one of the objects 
969 the position of the other object will not reflect their new value 
970 until you reload them from the database - see
971 L<DBIx::Class::Row/discard_changes>.
972
973 There are times when you will want to move objects as groups, such 
974 as changeing the parent of several objects at once - this directly 
975 conflicts with this problem.  One solution is for us to write a 
976 ResultSet class that supports a parent() method, for example.  Another 
977 solution is to somehow automagically modify the objects that exist 
978 in the current object's result set to have the new position value.
979
980 =head2 Default Values
981
982 Using a database defined default_value on one of your group columns
983 could result in the position not being assigned correctly.
984
985 =head1 AUTHOR
986
987  Original code framework
988    Aran Deltac <bluefeet@cpan.org>
989
990  Constraints support and code generalisation
991    Peter Rabbitson <ribasushi@cpan.org>
992
993 =head1 LICENSE
994
995 You may distribute this code under the same terms as Perl itself.
996