Cleaner error message for using source() without required argument
[dbsrgits/DBIx-Class.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 constraints 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     # if we're given a single value, turn it into a hashref
438     unless (ref $to_group eq 'HASH') {
439         my @gcols = $self->_grouping_columns;
440
441         $self->throw_exception ('Single group supplied for a multi-column group identifier') if @gcols > 1;
442         $to_group = {$gcols[0] => $to_group};
443     }
444
445     my $position_column = $self->position_column;
446
447     return 0 if ( defined($to_position) and $to_position < 1 );
448
449     # check if someone changed the _grouping_columns - this will
450     # prevent _is_in_group working, so we need to requery the db
451     # for the original values
452     my (@dirty_cols, %values, $guard);
453     for ($self->_grouping_columns) {
454       $values{$_} = $self->get_column ($_);
455       push @dirty_cols, $_ if $self->is_column_changed ($_);
456     }
457
458     # re-query only the dirty columns, and restore them on the
459     # object (subsequent code will update them to the correct
460     # after-move values)
461     if (@dirty_cols) {
462       $guard = $self->result_source->schema->txn_scope_guard;
463
464       my $cursor = $self->result_source->resultset->search(
465         $self->ident_condition,
466         { select => \@dirty_cols },
467       )->cursor;
468
469       my @original_values = $cursor->next;
470       $self->set_inflated_columns ({ %values, map { $_ => shift @original_values } (@dirty_cols) });
471       delete $self->{_dirty_columns}{$_} for (@dirty_cols);
472     }
473
474     if ($self->_is_in_group ($to_group) ) {
475       my $ret;
476       if (defined $to_position) {
477         $ret = $self->move_to ($to_position);
478       }
479
480       $guard->commit if $guard;
481       return $ret||0;
482     }
483
484     $guard ||= $self->result_source->schema->txn_scope_guard;
485
486     # Move to end of current group to adjust siblings
487     $self->move_last;
488
489     $self->set_inflated_columns({ %$to_group, $position_column => undef });
490     my $new_group_last_posval = $self->_last_sibling_posval;
491     my $new_group_last_position = $self->_position_from_value (
492       $new_group_last_posval
493     );
494
495     if ( not defined($to_position) or $to_position > $new_group_last_position) {
496       $self->set_column(
497         $position_column => $new_group_last_position
498           ? $self->_next_position_value ( $new_group_last_posval )
499           : $self->_initial_position_value
500       );
501     }
502     else {
503       my $bumped_pos_val = $self->_position_value ($to_position);
504       my @between = map { $self->_position_value ($_) } ($to_position, $new_group_last_position);
505       $self->_shift_siblings (1, @between);   #shift right
506       $self->set_column( $position_column => $bumped_pos_val );
507     }
508
509     $self->_ordered_internal_update;
510
511     $guard->commit;
512
513     return 1;
514 }
515
516 =head2 insert
517
518 Overrides the DBIC insert() method by providing a default 
519 position number.  The default will be the number of rows in 
520 the table +1, thus positioning the new record at the last position.
521
522 =cut
523
524 sub insert {
525     my $self = shift;
526     my $position_column = $self->position_column;
527
528     unless ($self->get_column($position_column)) {
529         my $lsib_posval = $self->_last_sibling_posval;
530         $self->set_column(
531             $position_column => (defined $lsib_posval
532                 ? $self->_next_position_value ( $lsib_posval )
533                 : $self->_initial_position_value
534             )
535         );
536     }
537
538     return $self->next::method( @_ );
539 }
540
541 =head2 update
542
543 Overrides the DBIC update() method by checking for a change
544 to the position and/or group columns.  Movement within a
545 group or to another group is handled by repositioning
546 the appropriate siblings.  Position defaults to the end
547 of a new group if it has been changed to undef.
548
549 =cut
550
551 sub update {
552     my $self = shift;
553
554     # this is set by _ordered_internal_update()
555     return $self->next::method(@_) if $self->{_ORDERED_INTERNAL_UPDATE};
556
557     my $position_column = $self->position_column;
558     my @ordering_columns = ($self->_grouping_columns, $position_column);
559
560
561     # these steps are necessary to keep the external appearance of
562     # ->update($upd) so that other things overloading update() will
563     # work properly
564     my %original_values = $self->get_columns;
565     my %existing_changes = $self->get_dirty_columns;
566
567     # See if any of the *supplied* changes would affect the ordering
568     # The reason this is so contrived, is that we want to leverage
569     # the datatype aware value comparing, while at the same time
570     # keep the original value intact (it will be updated later by the
571     # corresponding routine)
572
573     my %upd = %{shift || {}};
574     my %changes = %existing_changes;
575
576     for (@ordering_columns) {
577         next unless exists $upd{$_};
578
579         # we do not want to keep propagating this to next::method
580         # as it will be a done deal by the time get there
581         my $value = delete $upd{$_};
582         $self->set_inflated_columns ({ $_ => $value });
583
584         # see if an update resulted in a dirty column
585         # it is important to preserve the old value, as it
586         # will be needed to carry on a successfull move()
587         # operation without re-querying the database
588         if ($self->is_column_changed ($_) && not exists $existing_changes{$_}) {
589             $changes{$_} = $value;
590             $self->set_inflated_columns ({ $_ => $original_values{$_} });
591             delete $self->{_dirty_columns}{$_};
592         }
593     }
594
595     # if nothing group/position related changed - short circuit
596     if (not grep { exists $changes{$_} } ( @ordering_columns ) ) {
597         return $self->next::method( \%upd, @_ );
598     }
599
600     {
601         my $guard = $self->result_source->schema->txn_scope_guard;
602
603         # if any of our grouping columns have been changed
604         if (grep { exists $changes{$_} } ($self->_grouping_columns) ) {
605
606             # create new_group by taking the current group and inserting changes
607             my $new_group = {$self->_grouping_clause};
608             foreach my $col (keys %$new_group) {
609                 $new_group->{$col} = $changes{$col} if exists $changes{$col};
610             }
611
612             $self->move_to_group(
613                 $new_group,
614                 (exists $changes{$position_column}
615                     # The FIXME bit contradicts the documentation: POD states that
616                     # when changing groups without supplying explicit positions in
617                     # move_to_group(), we push the item to the end of the group.
618                     # However when I was rewriting this, the position from the old
619                     # group was clearly passed to the new one
620                     # Probably needs to go away (by ribasushi)
621                     ? $changes{$position_column}    # means there was a position change supplied with the update too
622                     : $self->_position              # FIXME! (replace with undef)
623                 ),
624             );
625         }
626         elsif (exists $changes{$position_column}) {
627             $self->move_to($changes{$position_column});
628         }
629
630         my @res;
631         if (not defined wantarray) {
632             $self->next::method( \%upd, @_ );
633         }
634         elsif (wantarray) {
635             @res = $self->next::method( \%upd, @_ );
636         }
637         else {
638             $res[0] = $self->next::method( \%upd, @_ );
639         }
640
641         $guard->commit;
642         return wantarray ? @res : $res[0];
643     }
644 }
645
646 =head2 delete
647
648 Overrides the DBIC delete() method by first moving the object 
649 to the last position, then deleting it, thus ensuring the
650 integrity of the positions.
651
652 =cut
653
654 sub delete {
655     my $self = shift;
656
657     my $guard = $self->result_source->schema->txn_scope_guard;
658
659     $self->move_last;
660
661     my @res;
662     if (not defined wantarray) {
663         $self->next::method( @_ );
664     }
665     elsif (wantarray) {
666         @res = $self->next::method( @_ );
667     }
668     else {
669         $res[0] = $self->next::method( @_ );
670     }
671
672     $guard->commit;
673     return wantarray ? @res : $res[0];
674 }
675
676 =head1 METHODS FOR EXTENDING ORDERED
677
678 You would want to override the methods below if you use sparse
679 (non-linear) or non-numeric position values. This can be useful
680 if you are working with preexisting non-normalised position data,
681 or if you need to work with materialized path columns.
682
683 =head2 _position_from_value
684
685   my $num_pos = $item->_position_from_value ( $pos_value )
686
687 Returns the B<absolute numeric position> of an object with a B<position
688 value> set to C<$pos_value>. By default simply returns C<$pos_value>.
689
690 =cut
691 sub _position_from_value {
692     my ($self, $val) = @_;
693
694     return 0 unless defined $val;
695
696 #    #the right way to do this
697 #    return $self -> _group_rs
698 #                 -> search({ $self->position_column => { '<=', $val } })
699 #                 -> count
700
701     return $val;
702 }
703
704 =head2 _position_value
705
706   my $pos_value = $item->_position_value ( $pos )
707
708 Returns the B<value> of L</position_column> of the object at numeric
709 position C<$pos>. By default simply returns C<$pos>.
710
711 =cut
712 sub _position_value {
713     my ($self, $pos) = @_;
714
715 #    #the right way to do this (not optimized)
716 #    my $position_column = $self->position_column;
717 #    return $self -> _group_rs
718 #                 -> search({}, { order_by => $position_column })
719 #                 -> slice ( $pos - 1)
720 #                 -> single
721 #                 -> get_column ($position_column);
722
723     return $pos;
724 }
725
726 =head2 _initial_position_value
727
728   __PACKAGE__->_initial_position_value(0);
729
730 This method specifies a B<value> of L</position_column> which is assigned
731 to the first inserted element of a group, if no value was supplied at
732 insertion time. All subsequent values are derived from this one by
733 L</_next_position_value> below. Defaults to 1.
734
735 =cut
736
737 __PACKAGE__->mk_classdata( '_initial_position_value' => 1 );
738
739 =head2 _next_position_value
740
741   my $new_value = $item->_next_position_value ( $position_value )
742
743 Returns a position B<value> that would be considered C<next> with
744 regards to C<$position_value>. Can be pretty much anything, given
745 that C<< $position_value < $new_value >> where C<< < >> is the
746 SQL comparison operator (usually works fine on strings). The
747 default method expects C<$position_value> to be numeric, and
748 returns C<$position_value + 1>
749
750 =cut
751 sub _next_position_value {
752     return $_[1] + 1;
753 }
754
755 =head2 _shift_siblings
756
757   $item->_shift_siblings ($direction, @between)
758
759 Shifts all siblings with B<positions values> in the range @between
760 (inclusive) by one position as specified by $direction (left if < 0,
761  right if > 0). By default simply increments/decrements each
762 L<position_column> value by 1, doing so in a way as to not violate
763 any existing constraints.
764
765 Note that if you override this method and have unique constraints
766 including the L<position_column> the shift is not a trivial task.
767 Refer to the implementation source of the default method for more
768 information.
769
770 =cut
771 sub _shift_siblings {
772     my ($self, $direction, @between) = @_;
773     return 0 unless $direction;
774
775     my $position_column = $self->position_column;
776
777     my ($op, $ord);
778     if ($direction < 0) {
779         $op = '-';
780         $ord = 'asc';
781     }
782     else {
783         $op = '+';
784         $ord = 'desc';
785     }
786
787     my $shift_rs = $self->_group_rs-> search ({ $position_column => { -between => \@between } });
788
789     # some databases (sqlite) are dumb and can not do a blanket
790     # increment/decrement. So what we do here is check if the
791     # position column is part of a unique constraint, and do a
792     # one-by-one update if this is the case
793
794     my $rsrc = $self->result_source;
795
796     if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $rsrc->unique_constraints }} ) ) ) {
797
798         my @pcols = $rsrc->_pri_cols;
799         my $cursor = $shift_rs->search ({}, { order_by => { "-$ord", $position_column }, columns => \@pcols } )->cursor;
800         my $rs = $self->result_source->resultset;
801
802         my @all_pks = $cursor->all;
803         while (my $pks = shift @all_pks) {
804           my $cond;
805           for my $i (0.. $#pcols) {
806             $cond->{$pcols[$i]} = $pks->[$i];
807           }
808
809           $rs->search($cond)->update ({ $position_column => \ "$position_column $op 1" } );
810         }
811     }
812     else {
813         $shift_rs->update ({ $position_column => \ "$position_column $op 1" } );
814     }
815 }
816
817 =head1 PRIVATE METHODS
818
819 These methods are used internally.  You should never have the 
820 need to use them.
821
822 =head2 _group_rs
823
824 This method returns a resultset containing all members of the row
825 group (including the row itself).
826
827 =cut
828 sub _group_rs {
829     my $self = shift;
830     return $self->result_source->resultset->search({$self->_grouping_clause()});
831 }
832
833 =head2 _siblings
834
835 Returns an unordered resultset of all objects in the same group
836 excluding the object you called this method on.
837
838 =cut
839 sub _siblings {
840     my $self = shift;
841     my $position_column = $self->position_column;
842     return $self->_group_rs->search(
843         { $position_column => { '!=' => $self->get_column($position_column) } },
844     );
845 }
846
847 =head2 _position
848
849   my $num_pos = $item->_position;
850
851 Returns the B<absolute numeric position> of the current object, with the
852 first object being at position 1, its sibling at position 2 and so on.
853
854 =cut
855 sub _position {
856     my $self = shift;
857     return $self->_position_from_value ($self->get_column ($self->position_column) );
858 }
859
860 =head2 _grouping_clause
861
862 This method returns one or more name=>value pairs for limiting a search
863 by the grouping column(s).  If the grouping column is not defined then 
864 this will return an empty list.
865
866 =cut
867 sub _grouping_clause {
868     my( $self ) = @_;
869     return map {  $_ => $self->get_column($_)  } $self->_grouping_columns();
870 }
871
872 =head2 _get_grouping_columns
873
874 Returns a list of the column names used for grouping, regardless of whether
875 they were specified as an arrayref or a single string, and returns ()
876 if there is no grouping.
877
878 =cut
879 sub _grouping_columns {
880     my( $self ) = @_;
881     my $col = $self->grouping_column();
882     if (ref $col eq 'ARRAY') {
883         return @$col;
884     } elsif ($col) {
885         return ( $col );
886     } else {
887         return ();
888     }
889 }
890
891 =head2 _is_in_group
892
893     $item->_is_in_group( {user => 'fred', list => 'work'} )
894
895 Returns true if the object is in the group represented by hashref $other
896
897 =cut
898 sub _is_in_group {
899     my ($self, $other) = @_;
900     my $current = {$self->_grouping_clause};
901
902     no warnings qw/uninitialized/;
903
904     return 0 if (
905         join ("\x00", sort keys %$current)
906             ne
907         join ("\x00", sort keys %$other)
908     );
909     for my $key (keys %$current) {
910         return 0 if $current->{$key} ne $other->{$key};
911     }
912     return 1;
913 }
914
915 =head2 _ordered_internal_update
916
917 This is a short-circuited method, that is used internally by this
918 module to update positioning values in isolation (i.e. without
919 triggering any of the positioning integrity code).
920
921 Some day you might get confronted by datasets that have ambiguous
922 positioning data (e.g. duplicate position values within the same group,
923 in a table without unique constraints). When manually fixing such data
924 keep in mind that you can not invoke L<DBIx::Class::Row/update> like
925 you normally would, as it will get confused by the wrong data before
926 having a chance to update the ill-defined row. If you really know what
927 you are doing use this method which bypasses any hooks introduced by
928 this module.
929
930 =cut
931
932 sub _ordered_internal_update {
933     my $self = shift;
934     local $self->{_ORDERED_INTERNAL_UPDATE} = 1;
935     return $self->update (@_);
936 }
937
938 1;
939
940 __END__
941
942 =head1 CAVEATS
943
944 =head2 Resultset Methods
945
946 Note that all Insert/Create/Delete overrides are happening on
947 L<DBIx::Class::Row> methods only. If you use the
948 L<DBIx::Class::ResultSet> versions of
949 L<update|DBIx::Class::ResultSet/update> or
950 L<delete|DBIx::Class::ResultSet/delete>, all logic present in this
951 module will be bypassed entirely (possibly resulting in a broken
952 order-tree). Instead always use the
953 L<update_all|DBIx::Class::ResultSet/update_all> and
954 L<delete_all|DBIx::Class::ResultSet/delete_all> methods, which will
955 invoke the corresponding L<row|DBIx::Class::Row> method on every
956 member of the given resultset.
957
958 =head2 Race Condition on Insert
959
960 If a position is not specified for an insert, a position
961 will be chosen based either on L</_initial_position_value> or
962 L</_next_position_value>, depending if there are already some
963 items in the current group. The space of time between the
964 necessary selects and insert introduces a race condition.
965 Having unique constraints on your position/group columns,
966 and using transactions (see L<DBIx::Class::Storage/txn_do>)
967 will prevent such race conditions going undetected.
968
969 =head2 Multiple Moves
970
971 Be careful when issuing move_* methods to multiple objects.  If 
972 you've pre-loaded the objects then when you move one of the objects 
973 the position of the other object will not reflect their new value 
974 until you reload them from the database - see
975 L<DBIx::Class::Row/discard_changes>.
976
977 There are times when you will want to move objects as groups, such 
978 as changing the parent of several objects at once - this directly 
979 conflicts with this problem.  One solution is for us to write a 
980 ResultSet class that supports a parent() method, for example.  Another 
981 solution is to somehow automagically modify the objects that exist 
982 in the current object's result set to have the new position value.
983
984 =head2 Default Values
985
986 Using a database defined default_value on one of your group columns
987 could result in the position not being assigned correctly.
988
989 =head1 AUTHOR
990
991  Original code framework
992    Aran Deltac <bluefeet@cpan.org>
993
994  Constraints support and code generalisation
995    Peter Rabbitson <ribasushi@cpan.org>
996
997 =head1 LICENSE
998
999 You may distribute this code under the same terms as Perl itself.
1000