Unqualify imported functions
[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 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         my $want = wantarray();
632         if (not defined $want) {
633             $self->next::method( \%upd, @_ );
634         }
635         elsif ($want) {
636             @res = $self->next::method( \%upd, @_ );
637         }
638         else {
639             $res[0] = $self->next::method( \%upd, @_ );
640         }
641
642         $guard->commit;
643         return $want ? @res : $res[0];
644     }
645 }
646
647 =head2 delete
648
649 Overrides the DBIC delete() method by first moving the object 
650 to the last position, then deleting it, thus ensuring the
651 integrity of the positions.
652
653 =cut
654
655 sub delete {
656     my $self = shift;
657
658     my $guard = $self->result_source->schema->txn_scope_guard;
659
660     $self->move_last;
661
662     my @res;
663     my $want = wantarray();
664     if (not defined $want) {
665         $self->next::method( @_ );
666     }
667     elsif ($want) {
668         @res = $self->next::method( @_ );
669     }
670     else {
671         $res[0] = $self->next::method( @_ );
672     }
673
674     $guard->commit;
675     return $want ? @res : $res[0];
676 }
677
678 =head1 METHODS FOR EXTENDING ORDERED
679
680 You would want to override the methods below if you use sparse
681 (non-linear) or non-numeric position values. This can be useful
682 if you are working with preexisting non-normalised position data,
683 or if you need to work with materialized path columns.
684
685 =head2 _position_from_value
686
687   my $num_pos = $item->_position_from_value ( $pos_value )
688
689 Returns the B<absolute numeric position> of an object with a B<position
690 value> set to C<$pos_value>. By default simply returns C<$pos_value>.
691
692 =cut
693 sub _position_from_value {
694     my ($self, $val) = @_;
695
696     return 0 unless defined $val;
697
698 #    #the right way to do this
699 #    return $self -> _group_rs
700 #                 -> search({ $self->position_column => { '<=', $val } })
701 #                 -> count
702
703     return $val;
704 }
705
706 =head2 _position_value
707
708   my $pos_value = $item->_position_value ( $pos )
709
710 Returns the B<value> of L</position_column> of the object at numeric
711 position C<$pos>. By default simply returns C<$pos>.
712
713 =cut
714 sub _position_value {
715     my ($self, $pos) = @_;
716
717 #    #the right way to do this (not optimized)
718 #    my $position_column = $self->position_column;
719 #    return $self -> _group_rs
720 #                 -> search({}, { order_by => $position_column })
721 #                 -> slice ( $pos - 1)
722 #                 -> single
723 #                 -> get_column ($position_column);
724
725     return $pos;
726 }
727
728 =head2 _initial_position_value
729
730   __PACKAGE__->_initial_position_value(0);
731
732 This method specifies a B<value> of L</position_column> which is assigned
733 to the first inserted element of a group, if no value was supplied at
734 insertion time. All subsequent values are derived from this one by
735 L</_next_position_value> below. Defaults to 1.
736
737 =cut
738
739 __PACKAGE__->mk_classdata( '_initial_position_value' => 1 );
740
741 =head2 _next_position_value
742
743   my $new_value = $item->_next_position_value ( $position_value )
744
745 Returns a position B<value> that would be considered C<next> with
746 regards to C<$position_value>. Can be pretty much anything, given
747 that C<< $position_value < $new_value >> where C<< < >> is the
748 SQL comparison operator (usually works fine on strings). The
749 default method expects C<$position_value> to be numeric, and
750 returns C<$position_value + 1>
751
752 =cut
753 sub _next_position_value {
754     return $_[1] + 1;
755 }
756
757 =head2 _shift_siblings
758
759   $item->_shift_siblings ($direction, @between)
760
761 Shifts all siblings with B<positions values> in the range @between
762 (inclusive) by one position as specified by $direction (left if < 0,
763  right if > 0). By default simply increments/decrements each
764 L<position_column> value by 1, doing so in a way as to not violate
765 any existing constraints.
766
767 Note that if you override this method and have unique constraints
768 including the L<position_column> the shift is not a trivial task.
769 Refer to the implementation source of the default method for more
770 information.
771
772 =cut
773 sub _shift_siblings {
774     my ($self, $direction, @between) = @_;
775     return 0 unless $direction;
776
777     my $position_column = $self->position_column;
778
779     my ($op, $ord);
780     if ($direction < 0) {
781         $op = '-';
782         $ord = 'asc';
783     }
784     else {
785         $op = '+';
786         $ord = 'desc';
787     }
788
789     my $shift_rs = $self->_group_rs-> search ({ $position_column => { -between => \@between } });
790
791     # some databases (sqlite) are dumb and can not do a blanket
792     # increment/decrement. So what we do here is check if the
793     # position column is part of a unique constraint, and do a
794     # one-by-one update if this is the case
795
796     my $rsrc = $self->result_source;
797
798     if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $rsrc->unique_constraints }} ) ) ) {
799
800         my @pcols = $rsrc->_pri_cols;
801         my $cursor = $shift_rs->search ({}, { order_by => { "-$ord", $position_column }, columns => \@pcols } )->cursor;
802         my $rs = $self->result_source->resultset;
803
804         my @all_pks = $cursor->all;
805         while (my $pks = shift @all_pks) {
806           my $cond;
807           for my $i (0.. $#pcols) {
808             $cond->{$pcols[$i]} = $pks->[$i];
809           }
810
811           $rs->search($cond)->update ({ $position_column => \ "$position_column $op 1" } );
812         }
813     }
814     else {
815         $shift_rs->update ({ $position_column => \ "$position_column $op 1" } );
816     }
817 }
818
819 =head1 PRIVATE METHODS
820
821 These methods are used internally.  You should never have the 
822 need to use them.
823
824 =head2 _group_rs
825
826 This method returns a resultset containing all members of the row
827 group (including the row itself).
828
829 =cut
830 sub _group_rs {
831     my $self = shift;
832     return $self->result_source->resultset->search({$self->_grouping_clause()});
833 }
834
835 =head2 _siblings
836
837 Returns an unordered resultset of all objects in the same group
838 excluding the object you called this method on.
839
840 =cut
841 sub _siblings {
842     my $self = shift;
843     my $position_column = $self->position_column;
844     return $self->_group_rs->search(
845         { $position_column => { '!=' => $self->get_column($position_column) } },
846     );
847 }
848
849 =head2 _position
850
851   my $num_pos = $item->_position;
852
853 Returns the B<absolute numeric position> of the current object, with the
854 first object being at position 1, its sibling at position 2 and so on.
855
856 =cut
857 sub _position {
858     my $self = shift;
859     return $self->_position_from_value ($self->get_column ($self->position_column) );
860 }
861
862 =head2 _grouping_clause
863
864 This method returns one or more name=>value pairs for limiting a search
865 by the grouping column(s).  If the grouping column is not defined then 
866 this will return an empty list.
867
868 =cut
869 sub _grouping_clause {
870     my( $self ) = @_;
871     return map {  $_ => $self->get_column($_)  } $self->_grouping_columns();
872 }
873
874 =head2 _get_grouping_columns
875
876 Returns a list of the column names used for grouping, regardless of whether
877 they were specified as an arrayref or a single string, and returns ()
878 if there is no grouping.
879
880 =cut
881 sub _grouping_columns {
882     my( $self ) = @_;
883     my $col = $self->grouping_column();
884     if (ref $col eq 'ARRAY') {
885         return @$col;
886     } elsif ($col) {
887         return ( $col );
888     } else {
889         return ();
890     }
891 }
892
893 =head2 _is_in_group
894
895     $item->_is_in_group( {user => 'fred', list => 'work'} )
896
897 Returns true if the object is in the group represented by hashref $other
898
899 =cut
900 sub _is_in_group {
901     my ($self, $other) = @_;
902     my $current = {$self->_grouping_clause};
903
904     no warnings qw/uninitialized/;
905
906     return 0 if (
907         join ("\x00", sort keys %$current)
908             ne
909         join ("\x00", sort keys %$other)
910     );
911     for my $key (keys %$current) {
912         return 0 if $current->{$key} ne $other->{$key};
913     }
914     return 1;
915 }
916
917 =head2 _ordered_internal_update
918
919 This is a short-circuited method, that is used internally by this
920 module to update positioning values in isolation (i.e. without
921 triggering any of the positioning integrity code).
922
923 Some day you might get confronted by datasets that have ambiguous
924 positioning data (e.g. duplicate position values within the same group,
925 in a table without unique constraints). When manually fixing such data
926 keep in mind that you can not invoke L<DBIx::Class::Row/update> like
927 you normally would, as it will get confused by the wrong data before
928 having a chance to update the ill-defined row. If you really know what
929 you are doing use this method which bypasses any hooks introduced by
930 this module.
931
932 =cut
933
934 sub _ordered_internal_update {
935     my $self = shift;
936     local $self->{_ORDERED_INTERNAL_UPDATE} = 1;
937     return $self->update (@_);
938 }
939
940 1;
941
942 __END__
943
944 =head1 CAVEATS
945
946 =head2 Resultset Methods
947
948 Note that all Insert/Create/Delete overrides are happening on
949 L<DBIx::Class::Row> methods only. If you use the
950 L<DBIx::Class::ResultSet> versions of
951 L<update|DBIx::Class::ResultSet/update> or
952 L<delete|DBIx::Class::ResultSet/delete>, all logic present in this
953 module will be bypassed entirely (possibly resulting in a broken
954 order-tree). Instead always use the
955 L<update_all|DBIx::Class::ResultSet/update_all> and
956 L<delete_all|DBIx::Class::ResultSet/delete_all> methods, which will
957 invoke the corresponding L<row|DBIx::Class::Row> method on every
958 member of the given resultset.
959
960 =head2 Race Condition on Insert
961
962 If a position is not specified for an insert, a position
963 will be chosen based either on L</_initial_position_value> or
964 L</_next_position_value>, depending if there are already some
965 items in the current group. The space of time between the
966 necessary selects and insert introduces a race condition.
967 Having unique constraints on your position/group columns,
968 and using transactions (see L<DBIx::Class::Storage/txn_do>)
969 will prevent such race conditions going undetected.
970
971 =head2 Multiple Moves
972
973 Be careful when issuing move_* methods to multiple objects.  If 
974 you've pre-loaded the objects then when you move one of the objects 
975 the position of the other object will not reflect their new value 
976 until you reload them from the database - see
977 L<DBIx::Class::Row/discard_changes>.
978
979 There are times when you will want to move objects as groups, such 
980 as changing the parent of several objects at once - this directly 
981 conflicts with this problem.  One solution is for us to write a 
982 ResultSet class that supports a parent() method, for example.  Another 
983 solution is to somehow automagically modify the objects that exist 
984 in the current object's result set to have the new position value.
985
986 =head2 Default Values
987
988 Using a database defined default_value on one of your group columns
989 could result in the position not being assigned correctly.
990
991 =head1 AUTHOR
992
993  Original code framework
994    Aran Deltac <bluefeet@cpan.org>
995
996  Constraints support and code generalisation
997    Peter Rabbitson <ribasushi@cpan.org>
998
999 =head1 LICENSE
1000
1001 You may distribute this code under the same terms as Perl itself.
1002