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