Unqualify imported functions
[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;
d4daee7b 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 });
d4daee7b 67
a733c37f 68 my $rs = $item->siblings();
69 my @siblings = $item->siblings();
d4daee7b 70
118e6b96 71 my $sibling;
a733c37f 72 $sibling = $item->first_sibling();
73 $sibling = $item->last_sibling();
74 $sibling = $item->previous_sibling();
75 $sibling = $item->next_sibling();
d4daee7b 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
48580715 130that any unique constraints can not be violated. This value defaults
bd7ca9e8 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 $position_column = $self->position_column;
366
87b4a877 367 my $guard;
8f535707 368
87b4a877 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)
bd7ca9e8 373
87b4a877 374 $guard = $self->result_source->schema->txn_scope_guard;
b250066f 375
87b4a877 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 }
b250066f 385
87b4a877 386 my $from_position = $self->_position;
fa6b598f 387
87b4a877 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 }
8f535707 404
87b4a877 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 });
bd7ca9e8 410 }
87b4a877 411
412 $self->_shift_siblings ($direction, @between);
413 $self->_ordered_internal_update({ $position_column => $new_pos_val });
414
415 $guard->commit;
416 return 1;
bd7ca9e8 417}
fa6b598f 418
79dc353a 419=head2 move_to_group
420
421 $item->move_to_group( $group, $position );
422
423Moves the object to the specified position of the specified
424group, or to the end of the group if $position is undef.
4251 is returned on success, and 0 is returned if the object is
426already at the specified position of the specified group.
427
1d941d67 428$group may be specified as a single scalar if only one
429grouping column is in use, or as a hashref of column => value pairs
430if multiple grouping columns are in use.
fa6b598f 431
79dc353a 432=cut
433
434sub move_to_group {
435 my( $self, $to_group, $to_position ) = @_;
fa6b598f 436
c59dfc82 437 # if we're given a single value, turn it into a hashref
fa6b598f 438 unless (ref $to_group eq 'HASH') {
bd7ca9e8 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};
fa6b598f 443 }
444
79dc353a 445 my $position_column = $self->position_column;
79dc353a 446
79dc353a 447 return 0 if ( defined($to_position) and $to_position < 1 );
87b4a877 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 ($_);
79dc353a 456 }
457
87b4a877 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;
8f535707 463
87b4a877 464 my $cursor = $self->result_source->resultset->search(
465 $self->ident_condition,
466 { select => \@dirty_cols },
467 )->cursor;
bd7ca9e8 468
87b4a877 469 my @original_values = $cursor->next;
470 $self->set_inflated_columns ({ %values, map { $_ => shift @original_values } (@dirty_cols) });
a98b5b2f 471 delete $self->{_dirty_columns}{$_} for (@dirty_cols);
87b4a877 472 }
bd7ca9e8 473
87b4a877 474 if ($self->_is_in_group ($to_group) ) {
475 my $ret;
476 if (defined $to_position) {
477 $ret = $self->move_to ($to_position);
478 }
bd7ca9e8 479
87b4a877 480 $guard->commit if $guard;
481 return $ret||0;
482 }
bd7ca9e8 483
87b4a877 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 );
8f535707 494
87b4a877 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 );
bd7ca9e8 501 }
87b4a877 502 else {
503 my $bumped_pos_val = $self->_position_value ($to_position);
71ec1155 504 my @between = map { $self->_position_value ($_) } ($to_position, $new_group_last_position);
87b4a877 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;
79dc353a 514}
515
118e6b96 516=head2 insert
517
518Overrides the DBIC insert() method by providing a default
519position number. The default will be the number of rows in
520the table +1, thus positioning the new record at the last position.
521
522=cut
523
524sub insert {
525 my $self = shift;
526 my $position_column = $self->position_column;
bd7ca9e8 527
528 unless ($self->get_column($position_column)) {
d7c0e320 529 my $lsib_posval = $self->_last_sibling_posval;
bd7ca9e8 530 $self->set_column(
d7c0e320 531 $position_column => (defined $lsib_posval
532 ? $self->_next_position_value ( $lsib_posval )
bd7ca9e8 533 : $self->_initial_position_value
534 )
535 );
536 }
537
0a298c73 538 return $self->next::method( @_ );
118e6b96 539}
540
79dc353a 541=head2 update
542
543Overrides the DBIC update() method by checking for a change
544to the position and/or group columns. Movement within a
545group or to another group is handled by repositioning
546the appropriate siblings. Position defaults to the end
547of a new group if it has been changed to undef.
548
549=cut
550
551sub update {
552 my $self = shift;
553
bd7ca9e8 554 # this is set by _ordered_internal_update()
555 return $self->next::method(@_) if $self->{_ORDERED_INTERNAL_UPDATE};
79dc353a 556
bd7ca9e8 557 my $position_column = $self->position_column;
87b4a877 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
2adb95f6 564 my %original_values = $self->get_columns;
87b4a877 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 }
fa6b598f 594
bd7ca9e8 595 # if nothing group/position related changed - short circuit
87b4a877 596 if (not grep { exists $changes{$_} } ( @ordering_columns ) ) {
597 return $self->next::method( \%upd, @_ );
bd7ca9e8 598 }
fa6b598f 599
bd7ca9e8 600 {
8f535707 601 my $guard = $self->result_source->schema->txn_scope_guard;
602
bd7ca9e8 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) {
87b4a877 609 $new_group->{$col} = $changes{$col} if exists $changes{$col};
fa6b598f 610 }
bd7ca9e8 611
612 $self->move_to_group(
613 $new_group,
614 (exists $changes{$position_column}
87b4a877 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
bd7ca9e8 620 # Probably needs to go away (by ribasushi)
87b4a877 621 ? $changes{$position_column} # means there was a position change supplied with the update too
622 : $self->_position # FIXME! (replace with undef)
bd7ca9e8 623 ),
624 );
625 }
626 elsif (exists $changes{$position_column}) {
87b4a877 627 $self->move_to($changes{$position_column});
fa6b598f 628 }
629
8f535707 630 my @res;
631 my $want = wantarray();
632 if (not defined $want) {
87b4a877 633 $self->next::method( \%upd, @_ );
8f535707 634 }
635 elsif ($want) {
87b4a877 636 @res = $self->next::method( \%upd, @_ );
8f535707 637 }
638 else {
87b4a877 639 $res[0] = $self->next::method( \%upd, @_ );
8f535707 640 }
641
642 $guard->commit;
643 return $want ? @res : $res[0];
79dc353a 644 }
79dc353a 645}
646
118e6b96 647=head2 delete
648
649Overrides the DBIC delete() method by first moving the object
bd7ca9e8 650to the last position, then deleting it, thus ensuring the
118e6b96 651integrity of the positions.
652
653=cut
654
655sub delete {
656 my $self = shift;
8f535707 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( @_ );
bd7ca9e8 666 }
8f535707 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];
bd7ca9e8 676}
677
b250066f 678=head1 METHODS FOR EXTENDING ORDERED
bd7ca9e8 679
680You would want to override the methods below if you use sparse
681(non-linear) or non-numeric position values. This can be useful
682if you are working with preexisting non-normalised position data,
683or if you need to work with materialized path columns.
684
d7c0e320 685=head2 _position_from_value
686
69cd8a7f 687 my $num_pos = $item->_position_from_value ( $pos_value )
d7c0e320 688
689Returns the B<absolute numeric position> of an object with a B<position
690value> set to C<$pos_value>. By default simply returns C<$pos_value>.
691
692=cut
693sub _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
bd7ca9e8 706=head2 _position_value
707
708 my $pos_value = $item->_position_value ( $pos )
709
b250066f 710Returns the B<value> of L</position_column> of the object at numeric
bd7ca9e8 711position C<$pos>. By default simply returns C<$pos>.
712
713=cut
714sub _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
b250066f 732This method specifies a B<value> of L</position_column> which is assigned
bd7ca9e8 733to the first inserted element of a group, if no value was supplied at
734insertion time. All subsequent values are derived from this one by
735L</_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
b250066f 745Returns a position B<value> that would be considered C<next> with
bd7ca9e8 746regards to C<$position_value>. Can be pretty much anything, given
747that C<< $position_value < $new_value >> where C<< < >> is the
748SQL comparison operator (usually works fine on strings). The
749default method expects C<$position_value> to be numeric, and
750returns C<$position_value + 1>
751
752=cut
753sub _next_position_value {
754 return $_[1] + 1;
755}
756
757=head2 _shift_siblings
758
759 $item->_shift_siblings ($direction, @between)
760
b250066f 761Shifts 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
764L<position_column> value by 1, doing so in a way as to not violate
765any existing constraints.
766
767Note that if you override this method and have unique constraints
768including the L<position_column> the shift is not a trivial task.
769Refer to the implementation source of the default method for more
770information.
bd7ca9e8 771
772=cut
773sub _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
82a8f76f 796 my $rsrc = $self->result_source;
797
798 if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $rsrc->unique_constraints }} ) ) ) {
799
e8fb771b 800 my @pcols = $rsrc->_pri_cols;
82a8f76f 801 my $cursor = $shift_rs->search ({}, { order_by => { "-$ord", $position_column }, columns => \@pcols } )->cursor;
802 my $rs = $self->result_source->resultset;
803
a83cdbf2 804 my @all_pks = $cursor->all;
e8fb771b 805 while (my $pks = shift @all_pks) {
82a8f76f 806 my $cond;
807 for my $i (0.. $#pcols) {
e8fb771b 808 $cond->{$pcols[$i]} = $pks->[$i];
82a8f76f 809 }
bd7ca9e8 810
82a8f76f 811 $rs->search($cond)->update ({ $position_column => \ "$position_column $op 1" } );
bd7ca9e8 812 }
813 }
814 else {
815 $shift_rs->update ({ $position_column => \ "$position_column $op 1" } );
816 }
118e6b96 817}
818
7a76f44c 819=head1 PRIVATE METHODS
820
821These methods are used internally. You should never have the
822need to use them.
823
bd7ca9e8 824=head2 _group_rs
825
b250066f 826This method returns a resultset containing all members of the row
bd7ca9e8 827group (including the row itself).
828
829=cut
830sub _group_rs {
831 my $self = shift;
832 return $self->result_source->resultset->search({$self->_grouping_clause()});
833}
834
835=head2 _siblings
836
837Returns an unordered resultset of all objects in the same group
838excluding the object you called this method on.
839
840=cut
841sub _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
69cd8a7f 849=head2 _position
850
851 my $num_pos = $item->_position;
852
853Returns the B<absolute numeric position> of the current object, with the
854first object being at position 1, its sibling at position 2 and so on.
855
856=cut
857sub _position {
858 my $self = shift;
859 return $self->_position_from_value ($self->get_column ($self->position_column) );
860}
861
a733c37f 862=head2 _grouping_clause
118e6b96 863
bd7ca9e8 864This method returns one or more name=>value pairs for limiting a search
87b4a877 865by the grouping column(s). If the grouping column is not defined then
866this will return an empty list.
118e6b96 867
7a76f44c 868=cut
a733c37f 869sub _grouping_clause {
169bb185 870 my( $self ) = @_;
fa6b598f 871 return map { $_ => $self->get_column($_) } $self->_grouping_columns();
872}
873
fa6b598f 874=head2 _get_grouping_columns
875
876Returns a list of the column names used for grouping, regardless of whether
1d941d67 877they were specified as an arrayref or a single string, and returns ()
878if there is no grouping.
fa6b598f 879
880=cut
881sub _grouping_columns {
882 my( $self ) = @_;
a733c37f 883 my $col = $self->grouping_column();
fa6b598f 884 if (ref $col eq 'ARRAY') {
885 return @$col;
886 } elsif ($col) {
887 return ( $col );
888 } else {
889 return ();
133dd22a 890 }
7a76f44c 891}
892
bd7ca9e8 893=head2 _is_in_group
fa6b598f 894
895 $item->_is_in_group( {user => 'fred', list => 'work'} )
896
897Returns true if the object is in the group represented by hashref $other
bd7ca9e8 898
fa6b598f 899=cut
900sub _is_in_group {
901 my ($self, $other) = @_;
902 my $current = {$self->_grouping_clause};
bd7ca9e8 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 );
fa6b598f 911 for my $key (keys %$current) {
fa6b598f 912 return 0 if $current->{$key} ne $other->{$key};
913 }
914 return 1;
915}
916
b250066f 917=head2 _ordered_internal_update
918
919This is a short-circuited method, that is used internally by this
920module to update positioning values in isolation (i.e. without
921triggering any of the positioning integrity code).
922
f045efad 923Some day you might get confronted by datasets that have ambiguous
48580715 924positioning data (e.g. duplicate position values within the same group,
b250066f 925in a table without unique constraints). When manually fixing such data
926keep in mind that you can not invoke L<DBIx::Class::Row/update> like
f045efad 927you normally would, as it will get confused by the wrong data before
b250066f 928having a chance to update the ill-defined row. If you really know what
f045efad 929you are doing use this method which bypasses any hooks introduced by
b250066f 930this module.
931
932=cut
933
bd7ca9e8 934sub _ordered_internal_update {
935 my $self = shift;
936 local $self->{_ORDERED_INTERNAL_UPDATE} = 1;
937 return $self->update (@_);
938}
fa6b598f 939
7a76f44c 9401;
118e6b96 941
bd7ca9e8 942__END__
dc66dea1 943
bd7ca9e8 944=head1 CAVEATS
dc66dea1 945
65285cf7 946=head2 Resultset Methods
947
948Note that all Insert/Create/Delete overrides are happening on
949L<DBIx::Class::Row> methods only. If you use the
950L<DBIx::Class::ResultSet> versions of
951L<update|DBIx::Class::ResultSet/update> or
952L<delete|DBIx::Class::ResultSet/delete>, all logic present in this
953module will be bypassed entirely (possibly resulting in a broken
954order-tree). Instead always use the
955L<update_all|DBIx::Class::ResultSet/update_all> and
956L<delete_all|DBIx::Class::ResultSet/delete_all> methods, which will
957invoke the corresponding L<row|DBIx::Class::Row> method on every
958member of the given resultset.
959
133dd22a 960=head2 Race Condition on Insert
961
65285cf7 962If a position is not specified for an insert, a position
bd7ca9e8 963will be chosen based either on L</_initial_position_value> or
964L</_next_position_value>, depending if there are already some
965items in the current group. The space of time between the
966necessary selects and insert introduces a race condition.
967Having unique constraints on your position/group columns,
968and using transactions (see L<DBIx::Class::Storage/txn_do>)
969will prevent such race conditions going undetected.
118e6b96 970
133dd22a 971=head2 Multiple Moves
972
48580715 973Be careful when issuing move_* methods to multiple objects. If
133dd22a 974you've pre-loaded the objects then when you move one of the objects
975the position of the other object will not reflect their new value
bd7ca9e8 976until you reload them from the database - see
977L<DBIx::Class::Row/discard_changes>.
133dd22a 978
dc66dea1 979There are times when you will want to move objects as groups, such
48580715 980as changing the parent of several objects at once - this directly
133dd22a 981conflicts with this problem. One solution is for us to write a
982ResultSet class that supports a parent() method, for example. Another
983solution is to somehow automagically modify the objects that exist
984in the current object's result set to have the new position value.
985
58755bba 986=head2 Default Values
987
988Using a database defined default_value on one of your group columns
989could result in the position not being assigned correctly.
990
118e6b96 991=head1 AUTHOR
992
8f535707 993 Original code framework
994 Aran Deltac <bluefeet@cpan.org>
995
996 Constraints support and code generalisation
997 Peter Rabbitson <ribasushi@cpan.org>
118e6b96 998
999=head1 LICENSE
1000
1001You may distribute this code under the same terms as Perl itself.
1002