added resultset override for ordered as well as tests
[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
335ed892 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
335ed892 150
118e6b96 151sub siblings {
335ed892 152 my $self = shift;
153 return $self->_siblings->search( {}, { order_by => $self->position_column } );
118e6b96 154}
155
bd7ca9e8 156=head2 previous_siblings
118e6b96 157
bd7ca9e8 158 my $prev_rs = $item->previous_siblings();
159 my @prev_siblings = $item->previous_siblings();
118e6b96 160
bd7ca9e8 161Returns a resultset of all objects in the same group
162positioned before the object on which this method was called.
118e6b96 163
164=cut
335ed892 165
bd7ca9e8 166sub previous_siblings {
335ed892 167 my $self = shift;
168 my $position_column = $self->position_column;
169 my $position = $self->get_column($position_column);
170 return (
171 defined $position
172 ? $self->_siblings->search( { $position_column => { '<', $position } } )
173 : $self->_siblings
174 );
118e6b96 175}
176
bd7ca9e8 177=head2 next_siblings
118e6b96 178
bd7ca9e8 179 my $next_rs = $item->next_siblings();
180 my @next_siblings = $item->next_siblings();
118e6b96 181
bd7ca9e8 182Returns a resultset of all objects in the same group
183positioned after the object on which this method was called.
118e6b96 184
185=cut
335ed892 186
bd7ca9e8 187sub next_siblings {
335ed892 188 my $self = shift;
189 my $position_column = $self->position_column;
190 my $position = $self->get_column($position_column);
191 return (
192 defined $position
193 ? $self->_siblings->search( { $position_column => { '>', $position } } )
194 : $self->_siblings
195 );
118e6b96 196}
197
198=head2 previous_sibling
199
a733c37f 200 my $sibling = $item->previous_sibling();
118e6b96 201
bd7ca9e8 202Returns the sibling that resides one position back. Returns 0
a8492531 203if the current object is the first one.
118e6b96 204
205=cut
206
207sub previous_sibling {
335ed892 208 my $self = shift;
209 my $position_column = $self->position_column;
bd7ca9e8 210
335ed892 211 my $psib =
212 $self->previous_siblings->search( {},
213 { rows => 1, order_by => { '-desc' => $position_column } },
bd7ca9e8 214 )->single;
215
335ed892 216 return defined $psib ? $psib : 0;
bd7ca9e8 217}
218
219=head2 first_sibling
220
221 my $sibling = $item->first_sibling();
222
223Returns the first sibling object, or 0 if the first sibling
224is this sibling.
225
226=cut
227
228sub first_sibling {
335ed892 229 my $self = shift;
230 my $position_column = $self->position_column;
bd7ca9e8 231
335ed892 232 my $fsib =
233 $self->previous_siblings->search( {},
234 { rows => 1, order_by => { '-asc' => $position_column } },
bd7ca9e8 235 )->single;
236
335ed892 237 return defined $fsib ? $fsib : 0;
118e6b96 238}
239
240=head2 next_sibling
241
a733c37f 242 my $sibling = $item->next_sibling();
118e6b96 243
bd7ca9e8 244Returns the sibling that resides one position forward. Returns 0
a8492531 245if the current object is the last one.
118e6b96 246
247=cut
248
249sub next_sibling {
335ed892 250 my $self = shift;
251 my $position_column = $self->position_column;
252 my $nsib =
253 $self->next_siblings->search( {},
254 { rows => 1, order_by => { '-asc' => $position_column } },
bd7ca9e8 255 )->single;
256
335ed892 257 return defined $nsib ? $nsib : 0;
bd7ca9e8 258}
259
260=head2 last_sibling
261
262 my $sibling = $item->last_sibling();
263
264Returns the last sibling, or 0 if the last sibling is this
265sibling.
266
267=cut
268
269sub last_sibling {
335ed892 270 my $self = shift;
271 my $position_column = $self->position_column;
272 my $lsib =
273 $self->next_siblings->search( {},
274 { rows => 1, order_by => { '-desc' => $position_column } },
bd7ca9e8 275 )->single;
276
335ed892 277 return defined $lsib ? $lsib : 0;
118e6b96 278}
279
d7c0e320 280# an optimized method to get the last sibling position value without inflating a row object
281sub _last_sibling_posval {
335ed892 282 my $self = shift;
283 my $position_column = $self->position_column;
82a8f76f 284
335ed892 285 my $cursor = $self->next_siblings->search(
286 {},
287 {
288 rows => 1,
289 order_by => { '-desc' => $position_column },
290 select => $position_column
291 },
292 )->cursor;
293
294 my ($pos) = $cursor->next;
295 return $pos;
82a8f76f 296}
297
80010e2b 298=head2 move_previous
118e6b96 299
a733c37f 300 $item->move_previous();
118e6b96 301
a8492531 302Swaps position with the sibling in the position previous in
303the list. Returns 1 on success, and 0 if the object is
304already the first one.
118e6b96 305
306=cut
307
80010e2b 308sub move_previous {
335ed892 309 my $self = shift;
310 return $self->move_to( $self->_position - 1 );
118e6b96 311}
312
80010e2b 313=head2 move_next
118e6b96 314
a733c37f 315 $item->move_next();
118e6b96 316
a8492531 317Swaps position with the sibling in the next position in the
318list. Returns 1 on success, and 0 if the object is already
319the last in the list.
118e6b96 320
321=cut
322
80010e2b 323sub move_next {
335ed892 324 my $self = shift;
325 return 0
326 unless defined
327 $self->_last_sibling_posval; # quick way to check for no more siblings
328 return $self->move_to( $self->_position + 1 );
118e6b96 329}
330
331=head2 move_first
332
a733c37f 333 $item->move_first();
118e6b96 334
a8492531 335Moves the object to the first position in the list. Returns 1
336on success, and 0 if the object is already the first.
118e6b96 337
338=cut
339
340sub move_first {
335ed892 341 return shift->move_to(1);
118e6b96 342}
343
344=head2 move_last
345
a733c37f 346 $item->move_last();
118e6b96 347
a8492531 348Moves the object to the last position in the list. Returns 1
349on success, and 0 if the object is already the last one.
118e6b96 350
351=cut
352
353sub move_last {
335ed892 354 my $self = shift;
355 my $last_posval = $self->_last_sibling_posval;
d7c0e320 356
335ed892 357 return 0 unless defined $last_posval;
d7c0e320 358
335ed892 359 return $self->move_to( $self->_position_from_value($last_posval) );
118e6b96 360}
361
362=head2 move_to
363
a733c37f 364 $item->move_to( $position );
118e6b96 365
a8492531 366Moves the object to the specified position. Returns 1 on
367success, and 0 if the object is already at the specified
368position.
118e6b96 369
370=cut
371
372sub move_to {
335ed892 373 my ( $self, $to_position ) = @_;
374 return 0 if ( $to_position < 1 );
bd7ca9e8 375
335ed892 376 my $position_column = $self->position_column;
8f535707 377
335ed892 378 my $guard;
bd7ca9e8 379
335ed892 380 if ( $self->is_column_changed($position_column) ) {
b250066f 381
335ed892 382 # something changed our position, we have no idea where we
383 # used to be - requery without using discard_changes
384 # (we need only a specific column back)
b250066f 385
335ed892 386 $guard = $self->result_source->schema->txn_scope_guard;
fa6b598f 387
335ed892 388 my $cursor =
389 $self->result_source->resultset->search( $self->ident_condition,
390 { select => $position_column },
391 )->cursor;
87b4a877 392
335ed892 393 my ($pos) = $cursor->next;
394 $self->$position_column($pos);
395 delete $self->{_dirty_columns}{$position_column};
396 }
397
398 my $from_position = $self->_position;
399
400 if ( $from_position == $to_position )
401 { # FIXME this will not work for non-numeric order
402 $guard->commit if $guard;
403 return 0;
404 }
405
406 $guard ||= $self->result_source->schema->txn_scope_guard;
407
408 my ( $direction, @between );
409 if ( $from_position < $to_position ) {
410 $direction = -1;
411 @between =
412 map { $self->_position_value($_) } ( $from_position + 1, $to_position );
413 } else {
414 $direction = 1;
415 @between =
416 map { $self->_position_value($_) } ( $to_position, $from_position - 1 );
417 }
418
419 my $new_pos_val =
420 $self->_position_value($to_position); # record this before the shift
421
422# we need to null-position the moved row if the position column is part of a constraint
423 if (
424 grep { $_ eq $position_column } (
425 map { @$_ } ( values %{ { $self->result_source->unique_constraints } } )
426 )
427 )
428 {
429 $self->_ordered_internal_update(
430 { $position_column => $self->null_position_value } );
431 }
432
433 $self->_shift_siblings( $direction, @between );
434 $self->_ordered_internal_update( { $position_column => $new_pos_val } );
435
436 $guard->commit;
437 return 1;
bd7ca9e8 438}
fa6b598f 439
79dc353a 440=head2 move_to_group
441
442 $item->move_to_group( $group, $position );
443
444Moves the object to the specified position of the specified
445group, or to the end of the group if $position is undef.
4461 is returned on success, and 0 is returned if the object is
447already at the specified position of the specified group.
448
1d941d67 449$group may be specified as a single scalar if only one
450grouping column is in use, or as a hashref of column => value pairs
451if multiple grouping columns are in use.
fa6b598f 452
79dc353a 453=cut
454
455sub move_to_group {
335ed892 456 my ( $self, $to_group, $to_position ) = @_;
457
458 # if we're given a single value, turn it into a hashref
459 unless ( ref $to_group eq 'HASH' ) {
460 my @gcols = $self->_grouping_columns;
461
462 $self->throw_exception(
463 'Single group supplied for a multi-column group identifier')
464 if @gcols > 1;
465 $to_group = { $gcols[0] => $to_group };
466 }
467
468 my $position_column = $self->position_column;
469
470 return 0 if ( defined($to_position) and $to_position < 1 );
471
472 # check if someone changed the _grouping_columns - this will
473 # prevent _is_in_group working, so we need to requery the db
474 # for the original values
475 my ( @dirty_cols, %values, $guard );
476 for ( $self->_grouping_columns ) {
477 $values{$_} = $self->get_column($_);
478 push @dirty_cols, $_ if $self->is_column_changed($_);
479 }
480
481 # re-query only the dirty columns, and restore them on the
482 # object (subsequent code will update them to the correct
483 # after-move values)
484 if (@dirty_cols) {
485 $guard = $self->result_source->schema->txn_scope_guard;
486
487 my $cursor =
488 $self->result_source->resultset->search( $self->ident_condition,
489 { select => \@dirty_cols },
87b4a877 490 )->cursor;
bd7ca9e8 491
335ed892 492 my @original_values = $cursor->next;
493 $self->set_inflated_columns(
494 { %values, map { $_ => shift @original_values } (@dirty_cols) } );
495 delete $self->{_dirty_columns}{$_} for (@dirty_cols);
496 }
bd7ca9e8 497
335ed892 498 if ( $self->_is_in_group($to_group) ) {
499 my $ret;
500 if ( defined $to_position ) {
501 $ret = $self->move_to($to_position);
87b4a877 502 }
bd7ca9e8 503
335ed892 504 $guard->commit if $guard;
505 return $ret || 0;
506 }
87b4a877 507
335ed892 508 $guard ||= $self->result_source->schema->txn_scope_guard;
87b4a877 509
335ed892 510 # Move to end of current group to adjust siblings
511 $self->move_last;
512
513 $self->set_inflated_columns( { %$to_group, $position_column => undef } );
514 my $new_group_last_posval = $self->_last_sibling_posval;
515 my $new_group_last_position =
516 $self->_position_from_value($new_group_last_posval);
8f535707 517
335ed892 518 if ( not defined($to_position) or $to_position > $new_group_last_position ) {
519 $self->set_column(
87b4a877 520 $position_column => $new_group_last_position
335ed892 521 ? $self->_next_position_value($new_group_last_posval)
522 : $self->_initial_position_value
523 );
524 } else {
525 my $bumped_pos_val = $self->_position_value($to_position);
526 my @between =
527 map { $self->_position_value($_) }
528 ( $to_position, $new_group_last_position );
529 $self->_shift_siblings( 1, @between ); #shift right
530 $self->set_column( $position_column => $bumped_pos_val );
531 }
87b4a877 532
335ed892 533 $self->_ordered_internal_update;
87b4a877 534
335ed892 535 $guard->commit;
87b4a877 536
335ed892 537 return 1;
79dc353a 538}
539
118e6b96 540=head2 insert
541
542Overrides the DBIC insert() method by providing a default
543position number. The default will be the number of rows in
544the table +1, thus positioning the new record at the last position.
545
546=cut
547
548sub insert {
335ed892 549 my $self = shift;
550 my $position_column = $self->position_column;
551
552 unless ( $self->get_column($position_column) ) {
553 my $lsib_posval = $self->_last_sibling_posval;
554 $self->set_column(
555 $position_column => (
556 defined $lsib_posval
557 ? $self->_next_position_value($lsib_posval)
558 : $self->_initial_position_value
559 )
560 );
561 }
bd7ca9e8 562
335ed892 563 return $self->next::method(@_);
118e6b96 564}
565
79dc353a 566=head2 update
567
568Overrides the DBIC update() method by checking for a change
569to the position and/or group columns. Movement within a
570group or to another group is handled by repositioning
571the appropriate siblings. Position defaults to the end
572of a new group if it has been changed to undef.
573
574=cut
575
576sub update {
335ed892 577 my $self = shift;
578
579 # this is set by _ordered_internal_update()
580 return $self->next::method(@_) if $self->{_ORDERED_INTERNAL_UPDATE};
581
582 my $position_column = $self->position_column;
583 my @ordering_columns = ( $self->_grouping_columns, $position_column );
584
585 # these steps are necessary to keep the external appearance of
586 # ->update($upd) so that other things overloading update() will
587 # work properly
588 my %original_values = $self->get_columns;
589 my %existing_changes = $self->get_dirty_columns;
590
591 # See if any of the *supplied* changes would affect the ordering
592 # The reason this is so contrived, is that we want to leverage
593 # the datatype aware value comparing, while at the same time
594 # keep the original value intact (it will be updated later by the
595 # corresponding routine)
596
597 my %upd = %{ shift || {} };
598 my %changes = %existing_changes;
599
600 for (@ordering_columns) {
601 next unless exists $upd{$_};
602
603 # we do not want to keep propagating this to next::method
604 # as it will be a done deal by the time get there
605 my $value = delete $upd{$_};
606 $self->set_inflated_columns( { $_ => $value } );
607
608 # see if an update resulted in a dirty column
609 # it is important to preserve the old value, as it
610 # will be needed to carry on a successfull move()
611 # operation without re-querying the database
612 if ( $self->is_column_changed($_) && not exists $existing_changes{$_} ) {
613 $changes{$_} = $value;
614 $self->set_inflated_columns( { $_ => $original_values{$_} } );
615 delete $self->{_dirty_columns}{$_};
87b4a877 616 }
335ed892 617 }
618
619 # if nothing group/position related changed - short circuit
620 if ( not grep { exists $changes{$_} } (@ordering_columns) ) {
621 return $self->next::method( \%upd, @_ );
622 }
623
624 {
625 my $guard = $self->result_source->schema->txn_scope_guard;
626
627 # if any of our grouping columns have been changed
628 if ( grep { exists $changes{$_} } ( $self->_grouping_columns ) ) {
629
630 # create new_group by taking the current group and inserting changes
631 my $new_group = { $self->_grouping_clause };
632 foreach my $col ( keys %$new_group ) {
633 $new_group->{$col} = $changes{$col} if exists $changes{$col};
634 }
fa6b598f 635
335ed892 636 $self->move_to_group(
637 $new_group,
638 (
639 exists $changes{$position_column}
640
641 # The FIXME bit contradicts the documentation: POD states that
642 # when changing groups without supplying explicit positions in
643 # move_to_group(), we push the item to the end of the group.
644 # However when I was rewriting this, the position from the old
645 # group was clearly passed to the new one
646 # Probably needs to go away (by ribasushi)
647 ? $changes{ $position_column
648 } # means there was a position change supplied with the update too
649 : $self->_position # FIXME! (replace with undef)
650 ),
651 );
652 } elsif ( exists $changes{$position_column} ) {
653 $self->move_to( $changes{$position_column} );
bd7ca9e8 654 }
fa6b598f 655
335ed892 656 my @res;
657 if ( not defined wantarray ) {
658 $self->next::method( \%upd, @_ );
659 } elsif (wantarray) {
660 @res = $self->next::method( \%upd, @_ );
661 } else {
662 $res[0] = $self->next::method( \%upd, @_ );
79dc353a 663 }
335ed892 664
665 $guard->commit;
666 return wantarray ? @res : $res[0];
667 }
79dc353a 668}
669
118e6b96 670=head2 delete
671
672Overrides the DBIC delete() method by first moving the object
bd7ca9e8 673to the last position, then deleting it, thus ensuring the
118e6b96 674integrity of the positions.
675
676=cut
677
678sub delete {
335ed892 679 my $self = shift;
8f535707 680
335ed892 681 my $guard = $self->result_source->schema->txn_scope_guard;
8f535707 682
335ed892 683 $self->move_last;
8f535707 684
335ed892 685 my @res;
686 if ( not defined wantarray ) {
687 $self->next::method(@_);
688 } elsif (wantarray) {
689 @res = $self->next::method(@_);
690 } else {
691 $res[0] = $self->next::method(@_);
692 }
8f535707 693
335ed892 694 $guard->commit;
695 return wantarray ? @res : $res[0];
bd7ca9e8 696}
697
b250066f 698=head1 METHODS FOR EXTENDING ORDERED
bd7ca9e8 699
700You would want to override the methods below if you use sparse
701(non-linear) or non-numeric position values. This can be useful
702if you are working with preexisting non-normalised position data,
703or if you need to work with materialized path columns.
704
d7c0e320 705=head2 _position_from_value
706
69cd8a7f 707 my $num_pos = $item->_position_from_value ( $pos_value )
d7c0e320 708
709Returns the B<absolute numeric position> of an object with a B<position
710value> set to C<$pos_value>. By default simply returns C<$pos_value>.
711
712=cut
335ed892 713
d7c0e320 714sub _position_from_value {
335ed892 715 my ( $self, $val ) = @_;
d7c0e320 716
335ed892 717 return 0 unless defined $val;
d7c0e320 718
335ed892 719 # #the right way to do this
720 # return $self -> _group_rs
721 # -> search({ $self->position_column => { '<=', $val } })
722 # -> count
d7c0e320 723
335ed892 724 return $val;
d7c0e320 725}
726
bd7ca9e8 727=head2 _position_value
728
729 my $pos_value = $item->_position_value ( $pos )
730
b250066f 731Returns the B<value> of L</position_column> of the object at numeric
bd7ca9e8 732position C<$pos>. By default simply returns C<$pos>.
733
734=cut
335ed892 735
bd7ca9e8 736sub _position_value {
335ed892 737 my ( $self, $pos ) = @_;
bd7ca9e8 738
335ed892 739 # #the right way to do this (not optimized)
740 # my $position_column = $self->position_column;
741 # return $self -> _group_rs
742 # -> search({}, { order_by => $position_column })
743 # -> slice ( $pos - 1)
744 # -> single
745 # -> get_column ($position_column);
bd7ca9e8 746
335ed892 747 return $pos;
bd7ca9e8 748}
749
750=head2 _initial_position_value
751
752 __PACKAGE__->_initial_position_value(0);
753
b250066f 754This method specifies a B<value> of L</position_column> which is assigned
bd7ca9e8 755to the first inserted element of a group, if no value was supplied at
756insertion time. All subsequent values are derived from this one by
757L</_next_position_value> below. Defaults to 1.
758
759=cut
760
761__PACKAGE__->mk_classdata( '_initial_position_value' => 1 );
762
763=head2 _next_position_value
764
765 my $new_value = $item->_next_position_value ( $position_value )
766
b250066f 767Returns a position B<value> that would be considered C<next> with
bd7ca9e8 768regards to C<$position_value>. Can be pretty much anything, given
769that C<< $position_value < $new_value >> where C<< < >> is the
770SQL comparison operator (usually works fine on strings). The
771default method expects C<$position_value> to be numeric, and
772returns C<$position_value + 1>
773
774=cut
335ed892 775
bd7ca9e8 776sub _next_position_value {
335ed892 777 return $_[1] + 1;
bd7ca9e8 778}
779
780=head2 _shift_siblings
781
782 $item->_shift_siblings ($direction, @between)
783
b250066f 784Shifts all siblings with B<positions values> in the range @between
785(inclusive) by one position as specified by $direction (left if < 0,
786 right if > 0). By default simply increments/decrements each
787L<position_column> value by 1, doing so in a way as to not violate
788any existing constraints.
789
790Note that if you override this method and have unique constraints
791including the L<position_column> the shift is not a trivial task.
792Refer to the implementation source of the default method for more
793information.
bd7ca9e8 794
795=cut
82a8f76f 796
335ed892 797sub _shift_siblings {
798 my ( $self, $direction, @between ) = @_;
799 return 0 unless $direction;
800
801 my $position_column = $self->position_column;
802
803 my ( $op, $ord );
804 if ( $direction < 0 ) {
805 $op = '-';
806 $ord = 'asc';
807 } else {
808 $op = '+';
809 $ord = 'desc';
810 }
811
812 my $shift_rs = $self->_group_rs->search(
813 { $position_column => { -between => \@between } } );
814
815 # some databases (sqlite) are dumb and can not do a blanket
816 # increment/decrement. So what we do here is check if the
817 # position column is part of a unique constraint, and do a
818 # one-by-one update if this is the case
819
820 my $rsrc = $self->result_source;
821
822 if ( grep { $_ eq $position_column }
823 ( map { @$_ } ( values %{ { $rsrc->unique_constraints } } ) ) )
824 {
825
826 my @pcols = $rsrc->_pri_cols;
827 my $cursor =
828 $shift_rs->search( {},
829 { order_by => { "-$ord", $position_column }, columns => \@pcols } )
830 ->cursor;
831 my $rs = $self->result_source->resultset;
832
833 my @all_pks = $cursor->all;
834 while ( my $pks = shift @all_pks ) {
835 my $cond;
836 for my $i ( 0 .. $#pcols ) {
837 $cond->{ $pcols[$i] } = $pks->[$i];
838 }
bd7ca9e8 839
335ed892 840 $rs->search($cond)
841 ->update( { $position_column => \"$position_column $op 1" } );
bd7ca9e8 842 }
335ed892 843 } else {
844 $shift_rs->update( { $position_column => \"$position_column $op 1" } );
845 }
118e6b96 846}
847
7a76f44c 848=head1 PRIVATE METHODS
849
850These methods are used internally. You should never have the
851need to use them.
852
bd7ca9e8 853=head2 _group_rs
854
b250066f 855This method returns a resultset containing all members of the row
bd7ca9e8 856group (including the row itself).
857
858=cut
335ed892 859
bd7ca9e8 860sub _group_rs {
335ed892 861 my $self = shift;
862 return $self->result_source->resultset->search(
863 { $self->_grouping_clause() } );
bd7ca9e8 864}
865
866=head2 _siblings
867
868Returns an unordered resultset of all objects in the same group
869excluding the object you called this method on.
870
871=cut
335ed892 872
bd7ca9e8 873sub _siblings {
335ed892 874 my $self = shift;
875 my $position_column = $self->position_column;
876 return $self->_group_rs->search(
877 { $position_column => { '!=' => $self->get_column($position_column) } },
878 );
bd7ca9e8 879}
880
69cd8a7f 881=head2 _position
882
883 my $num_pos = $item->_position;
884
885Returns the B<absolute numeric position> of the current object, with the
886first object being at position 1, its sibling at position 2 and so on.
887
888=cut
335ed892 889
69cd8a7f 890sub _position {
335ed892 891 my $self = shift;
892 return $self->_position_from_value(
893 $self->get_column( $self->position_column ) );
69cd8a7f 894}
895
a733c37f 896=head2 _grouping_clause
118e6b96 897
bd7ca9e8 898This method returns one or more name=>value pairs for limiting a search
87b4a877 899by the grouping column(s). If the grouping column is not defined then
900this will return an empty list.
118e6b96 901
7a76f44c 902=cut
335ed892 903
a733c37f 904sub _grouping_clause {
335ed892 905 my ($self) = @_;
906 return map { $_ => $self->get_column($_) } $self->_grouping_columns();
fa6b598f 907}
908
fa6b598f 909=head2 _get_grouping_columns
910
911Returns a list of the column names used for grouping, regardless of whether
1d941d67 912they were specified as an arrayref or a single string, and returns ()
913if there is no grouping.
fa6b598f 914
915=cut
335ed892 916
fa6b598f 917sub _grouping_columns {
335ed892 918 my ($self) = @_;
919 my $col = $self->grouping_column();
920 if ( ref $col eq 'ARRAY' ) {
921 return @$col;
922 } elsif ($col) {
923 return ($col);
924 } else {
925 return ();
926 }
7a76f44c 927}
928
bd7ca9e8 929=head2 _is_in_group
fa6b598f 930
931 $item->_is_in_group( {user => 'fred', list => 'work'} )
932
933Returns true if the object is in the group represented by hashref $other
bd7ca9e8 934
fa6b598f 935=cut
bd7ca9e8 936
335ed892 937sub _is_in_group {
938 my ( $self, $other ) = @_;
939 my $current = { $self->_grouping_clause };
940
941 no warnings qw/uninitialized/;
942
943 return 0
944 if (
945 join( "\x00", sort keys %$current ) ne join( "\x00", sort keys %$other ) );
946 for my $key ( keys %$current ) {
947 return 0 if $current->{$key} ne $other->{$key};
948 }
949 return 1;
fa6b598f 950}
951
b250066f 952=head2 _ordered_internal_update
953
954This is a short-circuited method, that is used internally by this
955module to update positioning values in isolation (i.e. without
956triggering any of the positioning integrity code).
957
f045efad 958Some day you might get confronted by datasets that have ambiguous
48580715 959positioning data (e.g. duplicate position values within the same group,
b250066f 960in a table without unique constraints). When manually fixing such data
961keep in mind that you can not invoke L<DBIx::Class::Row/update> like
f045efad 962you normally would, as it will get confused by the wrong data before
b250066f 963having a chance to update the ill-defined row. If you really know what
f045efad 964you are doing use this method which bypasses any hooks introduced by
b250066f 965this module.
966
967=cut
968
bd7ca9e8 969sub _ordered_internal_update {
335ed892 970 my $self = shift;
971 local $self->{_ORDERED_INTERNAL_UPDATE} = 1;
972 return $self->update(@_);
973}
974
975=head2 table
976
977Overridden to provide a resultset class to override delete and update methods.
978
979Shamelessly stolen from InflateColumn::FS
980
981=cut
982
983sub table {
984 my $self = shift;
985 warn "**INSIDE Ordered->table**";
986 my $ret = $self->next::method(@_);
987 $self->result_source_instance->resultset_class(
988 'DBIx::Class::Ordered::ResultSet');
989 return $ret;
bd7ca9e8 990}
fa6b598f 991
7a76f44c 9921;
118e6b96 993
bd7ca9e8 994__END__
dc66dea1 995
bd7ca9e8 996=head1 CAVEATS
dc66dea1 997
65285cf7 998=head2 Resultset Methods
999
1000Note that all Insert/Create/Delete overrides are happening on
1001L<DBIx::Class::Row> methods only. If you use the
1002L<DBIx::Class::ResultSet> versions of
1003L<update|DBIx::Class::ResultSet/update> or
1004L<delete|DBIx::Class::ResultSet/delete>, all logic present in this
1005module will be bypassed entirely (possibly resulting in a broken
1006order-tree). Instead always use the
1007L<update_all|DBIx::Class::ResultSet/update_all> and
1008L<delete_all|DBIx::Class::ResultSet/delete_all> methods, which will
1009invoke the corresponding L<row|DBIx::Class::Row> method on every
1010member of the given resultset.
1011
133dd22a 1012=head2 Race Condition on Insert
1013
65285cf7 1014If a position is not specified for an insert, a position
bd7ca9e8 1015will be chosen based either on L</_initial_position_value> or
1016L</_next_position_value>, depending if there are already some
1017items in the current group. The space of time between the
1018necessary selects and insert introduces a race condition.
1019Having unique constraints on your position/group columns,
1020and using transactions (see L<DBIx::Class::Storage/txn_do>)
1021will prevent such race conditions going undetected.
118e6b96 1022
133dd22a 1023=head2 Multiple Moves
1024
48580715 1025Be careful when issuing move_* methods to multiple objects. If
133dd22a 1026you've pre-loaded the objects then when you move one of the objects
1027the position of the other object will not reflect their new value
bd7ca9e8 1028until you reload them from the database - see
1029L<DBIx::Class::Row/discard_changes>.
133dd22a 1030
dc66dea1 1031There are times when you will want to move objects as groups, such
48580715 1032as changing the parent of several objects at once - this directly
133dd22a 1033conflicts with this problem. One solution is for us to write a
1034ResultSet class that supports a parent() method, for example. Another
1035solution is to somehow automagically modify the objects that exist
1036in the current object's result set to have the new position value.
1037
58755bba 1038=head2 Default Values
1039
1040Using a database defined default_value on one of your group columns
1041could result in the position not being assigned correctly.
1042
118e6b96 1043=head1 AUTHOR
1044
8f535707 1045 Original code framework
1046 Aran Deltac <bluefeet@cpan.org>
1047
1048 Constraints support and code generalisation
1049 Peter Rabbitson <ribasushi@cpan.org>
118e6b96 1050
335ed892 1051 C<update> and C<delete> fix
1052 Devin Austin <dhoss@cpan.org>
1053
118e6b96 1054=head1 LICENSE
1055
1056You may distribute this code under the same terms as Perl itself.
1057