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