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