lib/DBIx/Class/Ordered.pm

   1 package DBIx::Class::Ordered;
   2 use strict;
   3 use warnings;
   4 use base qw( DBIx::Class );
   5
   6 use DBIx::Class::_Util qw( bag_eq fail_on_internal_call );
   7 use namespace::clean;
   8
   9 =head1 NAME
  10
  11 DBIx::Class::Ordered - Modify the position of objects in an ordered list.
  12
  13 =head1 SYNOPSIS
  14
  15 Create a table for your ordered data.
  16
  17   CREATE TABLE items (
  18     item_id INTEGER PRIMARY KEY AUTOINCREMENT,
  19     name TEXT NOT NULL,
  20     position INTEGER NOT NULL
  21   );
  22
  23 Optionally, add one or more columns to specify groupings, allowing you
  24 to maintain independent ordered lists within one table:
  25
  26   CREATE TABLE items (
  27     item_id INTEGER PRIMARY KEY AUTOINCREMENT,
  28     name TEXT NOT NULL,
  29     position INTEGER NOT NULL,
  30     group_id INTEGER NOT NULL
  31   );
  32
  33 Or even
  34
  35   CREATE TABLE items (
  36     item_id INTEGER PRIMARY KEY AUTOINCREMENT,
  37     name TEXT NOT NULL,
  38     position INTEGER NOT NULL,
  39     group_id INTEGER NOT NULL,
  40     other_group_id INTEGER NOT NULL
  41   );
  42
  43 In your Schema or DB class add "Ordered" to the top
  44 of the component list.
  45
  46   __PACKAGE__->load_components(qw( Ordered ... ));
  47
  48 Specify the column that stores the position number for
  49 each row.
  50
  51   package My::Item;
  52   __PACKAGE__->position_column('position');
  53
  54 If you are using one grouping column, specify it as follows:
  55
  56   __PACKAGE__->grouping_column('group_id');
  57
  58 Or if you have multiple grouping columns:
  59
  60   __PACKAGE__->grouping_column(['group_id', 'other_group_id']);
  61
  62 That's it, now you can change the position of your objects.
  63
  64   #!/use/bin/perl
  65   use My::Item;
  66
  67   my $item = My::Item->create({ name=>'Matt S. Trout' });
  68   # If using grouping_column:
  69   my $item = My::Item->create({ name=>'Matt S. Trout', group_id=>1 });
  70
  71   my $rs = $item->siblings();
  72   my @siblings = $item->siblings();
  73
  74   my $sibling;
  75   $sibling = $item->first_sibling();
  76   $sibling = $item->last_sibling();
  77   $sibling = $item->previous_sibling();
  78   $sibling = $item->next_sibling();
  79
  80   $item->move_previous();
  81   $item->move_next();
  82   $item->move_first();
  83   $item->move_last();
  84   $item->move_to( $position );
  85   $item->move_to_group( 'groupname' );
  86   $item->move_to_group( 'groupname', $position );
  87   $item->move_to_group( {group_id=>'groupname', 'other_group_id=>'othergroupname'} );
  88   $item->move_to_group( {group_id=>'groupname', 'other_group_id=>'othergroupname'}, $position );
  89
  90 =head1 DESCRIPTION
  91
  92 This module provides a simple interface for modifying the ordered
  93 position of DBIx::Class objects.
  94
  95 =head1 AUTO UPDATE
  96
  97 All of the move_* methods automatically update the rows involved in
  98 the query.  This is not configurable and is due to the fact that if you
  99 move a record it always causes other records in the list to be updated.
 100
 101 =head1 METHODS
 102
 103 =head2 position_column
 104
 105   __PACKAGE__->position_column('position');
 106
 107 Sets and retrieves the name of the column that stores the
 108 positional value of each record.  Defaults to "position".
 109
 110 =cut
 111
 112 __PACKAGE__->mk_classaccessor( 'position_column' => 'position' );
 113
 114 =head2 grouping_column
 115
 116   __PACKAGE__->grouping_column('group_id');
 117
 118 This method specifies a column to limit all queries in
 119 this module by.  This effectively allows you to have multiple
 120 ordered lists within the same table.
 121
 122 =cut
 123
 124 __PACKAGE__->mk_group_accessors( inherited => 'grouping_column' );
 125
 126 =head2 null_position_value
 127
 128   __PACKAGE__->null_position_value(undef);
 129
 130 This method specifies a value of L</position_column> which B<would
 131 never be assigned to a row> during normal operation. When
 132 a row is moved, its position is set to this value temporarily, so
 133 that any unique constraints can not be violated. This value defaults
 134 to 0, which should work for all cases except when your positions do
 135 indeed start from 0.
 136
 137 =cut
 138
 139 __PACKAGE__->mk_classaccessor( 'null_position_value' => 0 );
 140
 141 =head2 siblings
 142
 143   my $rs = $item->siblings();
 144   my @siblings = $item->siblings();
 145
 146 Returns an B<ordered> resultset of all other objects in the same
 147 group excluding the one you called it on.
 148
 149 Underneath calls L<DBIx::Class::ResultSet/search>, and therefore returns
 150 objects by implicitly invoking L<C<< ->all() >>|DBIx::Class::ResultSet/all>
 151 in list context.
 152
 153 The ordering is a backwards-compatibility artifact - if you need
 154 a resultset with no ordering applied use C<_siblings>
 155
 156 =cut
 157
 158 sub siblings {
 159     #my $self = shift;
 160
 161     DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS
 162       and
 163     wantarray
 164       and
 165     ! eval { fail_on_internal_call; 1 }
 166       and
 167     die "ILLEGAL LIST CONTEXT INVOCATION: $@";
 168
 169     # *MUST* be context sensitive due to legacy (DO NOT call search_rs)
 170     $_[0]->_siblings->search ({}, { order_by => $_[0]->position_column } );
 171 }
 172
 173 =head2 previous_siblings
 174
 175   my $prev_rs = $item->previous_siblings();
 176   my @prev_siblings = $item->previous_siblings();
 177
 178 Returns a resultset of all objects in the same group
 179 positioned before the object on which this method was called.
 180
 181 Underneath calls L<DBIx::Class::ResultSet/search>, and therefore returns
 182 objects by implicitly invoking L<C<< ->all() >>|DBIx::Class::ResultSet/all>
 183 in list context.
 184
 185 =cut
 186 sub previous_siblings {
 187     my $self = shift;
 188     my $position_column = $self->position_column;
 189     my $position = $self->get_column ($position_column);
 190
 191     DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS
 192       and
 193     wantarray
 194       and
 195     ! eval { fail_on_internal_call; 1 }
 196       and
 197     die "ILLEGAL LIST CONTEXT INVOCATION: $@";
 198
 199     # *MUST* be context sensitive due to legacy (DO NOT call search_rs)
 200     defined( $position )
 201         ? $self->_siblings->search ({ $position_column => { '<', $position } })
 202         : $self->_siblings
 203     ;
 204 }
 205
 206 =head2 next_siblings
 207
 208   my $next_rs = $item->next_siblings();
 209   my @next_siblings = $item->next_siblings();
 210
 211 Returns a resultset of all objects in the same group
 212 positioned after the object on which this method was called.
 213
 214 Underneath calls L<DBIx::Class::ResultSet/search>, and therefore returns
 215 objects by implicitly invoking L<C<< ->all() >>|DBIx::Class::ResultSet/all>
 216 in list context.
 217
 218 =cut
 219 sub next_siblings {
 220     my $self = shift;
 221     my $position_column = $self->position_column;
 222     my $position = $self->get_column ($position_column);
 223
 224     DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS
 225       and
 226     wantarray
 227       and
 228     ! eval { fail_on_internal_call; 1 }
 229       and
 230     die "ILLEGAL LIST CONTEXT INVOCATION: $@";
 231
 232     # *MUST* be context sensitive due to legacy (DO NOT call search_rs)
 233     defined( $position )
 234         ? $self->_siblings->search ({ $position_column => { '>', $position } })
 235         : $self->_siblings
 236     ;
 237 }
 238
 239 =head2 previous_sibling
 240
 241   my $sibling = $item->previous_sibling();
 242
 243 Returns the sibling that resides one position back.  Returns 0
 244 if the current object is the first one.
 245
 246 =cut
 247
 248 sub previous_sibling {
 249     my $self = shift;
 250     my $position_column = $self->position_column;
 251
 252     my $psib = $self->previous_siblings->search(
 253         {},
 254         { rows => 1, order_by => { '-desc' => $position_column } },
 255     )->single;
 256
 257     return defined( $psib ) ? $psib : 0;
 258 }
 259
 260 =head2 first_sibling
 261
 262   my $sibling = $item->first_sibling();
 263
 264 Returns the first sibling object, or 0 if the first sibling
 265 is this sibling.
 266
 267 =cut
 268
 269 sub first_sibling {
 270     my $self = shift;
 271     my $position_column = $self->position_column;
 272
 273     my $fsib = $self->previous_siblings->search(
 274         {},
 275         { rows => 1, order_by => { '-asc' => $position_column } },
 276     )->single;
 277
 278     return defined( $fsib ) ? $fsib : 0;
 279 }
 280
 281 =head2 next_sibling
 282
 283   my $sibling = $item->next_sibling();
 284
 285 Returns the sibling that resides one position forward. Returns 0
 286 if the current object is the last one.
 287
 288 =cut
 289
 290 sub next_sibling {
 291     my $self = shift;
 292     my $position_column = $self->position_column;
 293     my $nsib = $self->next_siblings->search(
 294         {},
 295         { rows => 1, order_by => { '-asc' => $position_column } },
 296     )->single;
 297
 298     return defined( $nsib ) ? $nsib : 0;
 299 }
 300
 301 =head2 last_sibling
 302
 303   my $sibling = $item->last_sibling();
 304
 305 Returns the last sibling, or 0 if the last sibling is this
 306 sibling.
 307
 308 =cut
 309
 310 sub last_sibling {
 311     my $self = shift;
 312     my $position_column = $self->position_column;
 313     my $lsib = $self->next_siblings->search(
 314         {},
 315         { rows => 1, order_by => { '-desc' => $position_column } },
 316     )->single;
 317
 318     return defined( $lsib ) ? $lsib : 0;
 319 }
 320
 321 # an optimized method to get the last sibling position value without inflating a result object
 322 sub _last_sibling_posval {
 323     my $self = shift;
 324     my $position_column = $self->position_column;
 325
 326     my $cursor = $self->next_siblings->search(
 327         {},
 328         { rows => 1, order_by => { '-desc' => $position_column }, select => $position_column },
 329     )->cursor;
 330
 331     ($cursor->next)[0];
 332 }
 333
 334 =head2 move_previous
 335
 336   $item->move_previous();
 337
 338 Swaps position with the sibling in the position previous in
 339 the list.  Returns 1 on success, and 0 if the object is
 340 already the first one.
 341
 342 =cut
 343
 344 sub move_previous {
 345     my $self = shift;
 346     return $self->move_to ($self->_position - 1);
 347 }
 348
 349 =head2 move_next
 350
 351   $item->move_next();
 352
 353 Swaps position with the sibling in the next position in the
 354 list.  Returns 1 on success, and 0 if the object is already
 355 the last in the list.
 356
 357 =cut
 358
 359 sub move_next {
 360     my $self = shift;
 361     return 0 unless defined $self->_last_sibling_posval;  # quick way to check for no more siblings
 362     return $self->move_to ($self->_position + 1);
 363 }
 364
 365 =head2 move_first
 366
 367   $item->move_first();
 368
 369 Moves the object to the first position in the list.  Returns 1
 370 on success, and 0 if the object is already the first.
 371
 372 =cut
 373
 374 sub move_first {
 375     return shift->move_to( 1 );
 376 }
 377
 378 =head2 move_last
 379
 380   $item->move_last();
 381
 382 Moves the object to the last position in the list.  Returns 1
 383 on success, and 0 if the object is already the last one.
 384
 385 =cut
 386
 387 sub move_last {
 388     my $self = shift;
 389     my $last_posval = $self->_last_sibling_posval;
 390
 391     return 0 unless defined $last_posval;
 392
 393     return $self->move_to( $self->_position_from_value ($last_posval) );
 394 }
 395
 396 =head2 move_to
 397
 398   $item->move_to( $position );
 399
 400 Moves the object to the specified position.  Returns 1 on
 401 success, and 0 if the object is already at the specified
 402 position.
 403
 404 =cut
 405
 406 sub move_to {
 407     my( $self, $to_position ) = @_;
 408     return 0 if ( $to_position < 1 );
 409
 410     my $position_column = $self->position_column;
 411
 412     my $rsrc = $self->result_source;
 413
 414     my $is_txn;
 415     if ($is_txn = $rsrc->schema->storage->transaction_depth) {
 416       # Reload position state from storage
 417       # The thinking here is that if we are in a transaction, it is
 418       # *more likely* the object went out of sync due to resultset
 419       # level shenanigans. Instead of always reloading (slow) - go
 420       # ahead and hand-hold only in the case of higher layers
 421       # requesting the safety of a txn
 422
 423       $self->store_column(
 424         $position_column,
 425         (  $rsrc->resultset
 426                  ->search($self->_storage_ident_condition, { rows => 1, columns => $position_column })
 427                   ->cursor
 428                    ->next
 429         )[0] || $self->throw_exception(
 430           sprintf "Unable to locate object '%s' in storage - object went ouf of sync...?",
 431           $self->ID
 432         ),
 433       );
 434       delete $self->{_dirty_columns}{$position_column};
 435     }
 436     elsif ($self->is_column_changed ($position_column) ) {
 437       # something changed our position, we need to know where we
 438       # used to be - use the stashed value
 439       $self->store_column($position_column, delete $self->{_column_data_in_storage}{$position_column});
 440       delete $self->{_dirty_columns}{$position_column};
 441     }
 442
 443     my $from_position = $self->_position;
 444
 445     if ( $from_position == $to_position ) {   # FIXME this will not work for non-numeric order
 446       return 0;
 447     }
 448
 449     my $guard = $is_txn ? undef : $rsrc->schema->txn_scope_guard;
 450
 451     my ($direction, @between);
 452     if ( $from_position < $to_position ) {
 453       $direction = -1;
 454       @between = map { $self->_position_value ($_) } ( $from_position + 1, $to_position );
 455     }
 456     else {
 457       $direction = 1;
 458       @between = map { $self->_position_value ($_) } ( $to_position, $from_position - 1 );
 459     }
 460
 461     my $new_pos_val = $self->_position_value ($to_position);  # record this before the shift
 462
 463     # we need to null-position the moved row if the position column is part of a constraint
 464     if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $rsrc->unique_constraints }} ) ) ) {
 465       $self->_ordered_internal_update({ $position_column => $self->null_position_value });
 466     }
 467
 468     $self->_shift_siblings ($direction, @between);
 469     $self->_ordered_internal_update({ $position_column => $new_pos_val });
 470
 471     $guard->commit if $guard;
 472     return 1;
 473 }
 474
 475 =head2 move_to_group
 476
 477   $item->move_to_group( $group, $position );
 478
 479 Moves the object to the specified position of the specified
 480 group, or to the end of the group if $position is undef.
 481 1 is returned on success, and 0 is returned if the object is
 482 already at the specified position of the specified group.
 483
 484 $group may be specified as a single scalar if only one
 485 grouping column is in use, or as a hashref of column => value pairs
 486 if multiple grouping columns are in use.
 487
 488 =cut
 489
 490 sub move_to_group {
 491     my( $self, $to_group, $to_position ) = @_;
 492
 493     # if we're given a single value, turn it into a hashref
 494     unless (ref $to_group eq 'HASH') {
 495         my @gcols = $self->_grouping_columns;
 496
 497         $self->throw_exception ('Single group supplied for a multi-column group identifier') if @gcols > 1;
 498         $to_group = {$gcols[0] => $to_group};
 499     }
 500
 501     my $position_column = $self->position_column;
 502
 503     return 0 if ( defined($to_position) and $to_position < 1 );
 504
 505     # check if someone changed the _grouping_columns - this will
 506     # prevent _is_in_group working, so we need to restore the
 507     # original stashed values
 508     for ($self->_grouping_columns) {
 509       if ($self->is_column_changed ($_)) {
 510         $self->store_column($_, delete $self->{_column_data_in_storage}{$_});
 511         delete $self->{_dirty_columns}{$_};
 512       }
 513     }
 514
 515     if ($self->_is_in_group ($to_group) ) {
 516       my $ret;
 517       if (defined $to_position) {
 518         $ret = $self->move_to ($to_position);
 519       }
 520
 521       return $ret||0;
 522     }
 523
 524     my $guard = $self->result_source->schema->txn_scope_guard;
 525
 526     # Move to end of current group to adjust siblings
 527     $self->move_last;
 528
 529     $self->set_inflated_columns({ %$to_group, $position_column => undef });
 530     my $new_group_last_posval = $self->_last_sibling_posval;
 531     my $new_group_last_position = $self->_position_from_value (
 532       $new_group_last_posval
 533     );
 534
 535     if ( not defined($to_position) or $to_position > $new_group_last_position) {
 536       $self->set_column(
 537         $position_column => $new_group_last_position
 538           ? $self->_next_position_value ( $new_group_last_posval )
 539           : $self->_initial_position_value
 540       );
 541     }
 542     else {
 543       my $bumped_pos_val = $self->_position_value ($to_position);
 544       my @between = map { $self->_position_value ($_) } ($to_position, $new_group_last_position);
 545       $self->_shift_siblings (1, @between);   #shift right
 546       $self->set_column( $position_column => $bumped_pos_val );
 547     }
 548
 549     $self->_ordered_internal_update;
 550
 551     $guard->commit;
 552
 553     return 1;
 554 }
 555
 556 =head2 insert
 557
 558 Overrides the DBIC insert() method by providing a default
 559 position number.  The default will be the number of rows in
 560 the table +1, thus positioning the new record at the last position.
 561
 562 =cut
 563
 564 sub insert {
 565     my $self = shift;
 566     my $position_column = $self->position_column;
 567
 568     unless ($self->get_column($position_column)) {
 569         my $lsib_posval = $self->_last_sibling_posval;
 570         $self->set_column(
 571             $position_column => (defined $lsib_posval
 572                 ? $self->_next_position_value ( $lsib_posval )
 573                 : $self->_initial_position_value
 574             )
 575         );
 576     }
 577
 578     return $self->next::method( @_ );
 579 }
 580
 581 =head2 update
 582
 583 Overrides the DBIC update() method by checking for a change
 584 to the position and/or group columns.  Movement within a
 585 group or to another group is handled by repositioning
 586 the appropriate siblings.  Position defaults to the end
 587 of a new group if it has been changed to undef.
 588
 589 =cut
 590
 591 sub update {
 592   my $self = shift;
 593
 594   # this is set by _ordered_internal_update()
 595   return $self->next::method(@_) if $self->result_source->schema->{_ORDERED_INTERNAL_UPDATE};
 596
 597   my $upd = shift;
 598   $self->set_inflated_columns($upd) if $upd;
 599
 600   my $position_column = $self->position_column;
 601   my @group_columns = $self->_grouping_columns;
 602
 603   # see if the order is already changed
 604   my $changed_ordering_cols = { map { $_ => $self->get_column($_) } grep { $self->is_column_changed($_) } ($position_column, @group_columns) };
 605
 606   # nothing changed - short circuit
 607   if (! keys %$changed_ordering_cols) {
 608     return $self->next::method( undef, @_ );
 609   }
 610   elsif (grep { exists $changed_ordering_cols->{$_} } @group_columns ) {
 611     $self->move_to_group(
 612       # since the columns are already re-set the _grouping_clause is correct
 613       # move_to_group() knows how to get the original storage values
 614       { $self->_grouping_clause },
 615
 616       # The FIXME bit contradicts the documentation: POD states that
 617       # when changing groups without supplying explicit positions in
 618       # move_to_group(), we push the item to the end of the group.
 619       # However when I was rewriting this, the position from the old
 620       # group was clearly passed to the new one
 621       # Probably needs to go away (by ribasushi)
 622       (exists $changed_ordering_cols->{$position_column}
 623         ? $changed_ordering_cols->{$position_column}  # means there was a position change supplied with the update too
 624         : $self->_position                            # FIXME! (replace with undef)
 625       ),
 626     );
 627   }
 628   else {
 629     $self->move_to($changed_ordering_cols->{$position_column});
 630   }
 631
 632   return $self;
 633 }
 634
 635 =head2 delete
 636
 637 Overrides the DBIC delete() method by first moving the object
 638 to the last position, then deleting it, thus ensuring the
 639 integrity of the positions.
 640
 641 =cut
 642
 643 sub delete {
 644     my $self = shift;
 645
 646     my $guard = $self->result_source->schema->txn_scope_guard;
 647
 648     $self->move_last;
 649
 650     $self->next::method( @_ );
 651
 652     $guard->commit;
 653
 654     return $self;
 655 }
 656
 657 # add the current position/group to the things we track old values for
 658 sub _track_storage_value {
 659   my ($self, $col) = @_;
 660   return (
 661     $self->next::method($col)
 662       ||
 663     grep { $_ eq $col } ($self->position_column, $self->_grouping_columns)
 664   );
 665 }
 666
 667 =head1 METHODS FOR EXTENDING ORDERED
 668
 669 You would want to override the methods below if you use sparse
 670 (non-linear) or non-numeric position values. This can be useful
 671 if you are working with preexisting non-normalised position data,
 672 or if you need to work with materialized path columns.
 673
 674 =head2 _position_from_value
 675
 676   my $num_pos = $item->_position_from_value ( $pos_value )
 677
 678 Returns the B<absolute numeric position> of an object with a B<position
 679 value> set to C<$pos_value>. By default simply returns C<$pos_value>.
 680
 681 =cut
 682 sub _position_from_value {
 683     my ($self, $val) = @_;
 684
 685     return 0 unless defined $val;
 686
 687 #    #the right way to do this
 688 #    return $self -> _group_rs
 689 #                 -> search({ $self->position_column => { '<=', $val } })
 690 #                 -> count
 691
 692     return $val;
 693 }
 694
 695 =head2 _position_value
 696
 697   my $pos_value = $item->_position_value ( $pos )
 698
 699 Returns the B<value> of L</position_column> of the object at numeric
 700 position C<$pos>. By default simply returns C<$pos>.
 701
 702 =cut
 703 sub _position_value {
 704     my ($self, $pos) = @_;
 705
 706 #    #the right way to do this (not optimized)
 707 #    my $position_column = $self->position_column;
 708 #    return $self -> _group_rs
 709 #                 -> search({}, { order_by => $position_column })
 710 #                 -> slice ( $pos - 1)
 711 #                 -> single
 712 #                 -> get_column ($position_column);
 713
 714     return $pos;
 715 }
 716
 717 =head2 _initial_position_value
 718
 719   __PACKAGE__->_initial_position_value(0);
 720
 721 This method specifies a B<value> of L</position_column> which is assigned
 722 to the first inserted element of a group, if no value was supplied at
 723 insertion time. All subsequent values are derived from this one by
 724 L</_next_position_value> below. Defaults to 1.
 725
 726 =cut
 727
 728 __PACKAGE__->mk_classaccessor( '_initial_position_value' => 1 );
 729
 730 =head2 _next_position_value
 731
 732   my $new_value = $item->_next_position_value ( $position_value )
 733
 734 Returns a position B<value> that would be considered C<next> with
 735 regards to C<$position_value>. Can be pretty much anything, given
 736 that C<< $position_value < $new_value >> where C<< < >> is the
 737 SQL comparison operator (usually works fine on strings). The
 738 default method expects C<$position_value> to be numeric, and
 739 returns C<$position_value + 1>
 740
 741 =cut
 742 sub _next_position_value {
 743     return $_[1] + 1;
 744 }
 745
 746 =head2 _shift_siblings
 747
 748   $item->_shift_siblings ($direction, @between)
 749
 750 Shifts all siblings with B<positions values> in the range @between
 751 (inclusive) by one position as specified by $direction (left if < 0,
 752  right if > 0). By default simply increments/decrements each
 753 L</position_column> value by 1, doing so in a way as to not violate
 754 any existing constraints.
 755
 756 Note that if you override this method and have unique constraints
 757 including the L</position_column> the shift is not a trivial task.
 758 Refer to the implementation source of the default method for more
 759 information.
 760
 761 =cut
 762 sub _shift_siblings {
 763     my ($self, $direction, @between) = @_;
 764     return 0 unless $direction;
 765
 766     my $position_column = $self->position_column;
 767
 768     my ($op, $ord);
 769     if ($direction < 0) {
 770         $op = '-';
 771         $ord = 'asc';
 772     }
 773     else {
 774         $op = '+';
 775         $ord = 'desc';
 776     }
 777
 778     my $shift_rs = $self->_group_rs-> search ({ $position_column => { -between => \@between } });
 779
 780     # some databases (sqlite, pg, perhaps others) are dumb and can not do a
 781     # blanket increment/decrement without violating a unique constraint.
 782     # So what we do here is check if the position column is part of a unique
 783     # constraint, and do a one-by-one update if this is the case.
 784     my $rsrc = $self->result_source;
 785
 786     # set in case there are more cascades combined with $rs->update => $rs_update_all overrides
 787     local $rsrc->schema->{_ORDERED_INTERNAL_UPDATE} = 1;
 788     my @pcols = $rsrc->primary_columns;
 789     if (
 790       grep { $_ eq $position_column } ( map { @$_ } (values %{{ $rsrc->unique_constraints }} ) )
 791     ) {
 792         my $clean_rs = $rsrc->resultset;
 793
 794         for ( $shift_rs->search (
 795           {}, { order_by => { "-$ord", $position_column }, select => [$position_column, @pcols] }
 796         )->cursor->all ) {
 797           my $pos = shift @$_;
 798           $clean_rs->find(@$_)->update ({ $position_column => $pos + ( ($op eq '+') ? 1 : -1 ) });
 799         }
 800     }
 801     else {
 802         $shift_rs->update ({ $position_column => \ "$position_column $op 1" } );
 803     }
 804 }
 805
 806
 807 # This method returns a resultset containing all members of the row
 808 # group (including the row itself).
 809 sub _group_rs {
 810     #my $self = shift;
 811
 812     DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS
 813       and
 814     wantarray
 815       and
 816     ! eval { fail_on_internal_call; 1 }
 817       and
 818     die "ILLEGAL LIST CONTEXT INVOCATION: $@";
 819
 820     # *MUST* be context sensitive due to legacy (DO NOT call search_rs)
 821     $_[0]->result_source->resultset->search({ $_[0]->_grouping_clause() });
 822 }
 823
 824 # Returns an unordered resultset of all objects in the same group
 825 # excluding the object you called this method on.
 826 sub _siblings {
 827     my $self = shift;
 828     my $position_column = $self->position_column;
 829     my $pos;
 830
 831     DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS
 832       and
 833     wantarray
 834       and
 835     ! eval { fail_on_internal_call; 1 }
 836       and
 837     die "ILLEGAL LIST CONTEXT INVOCATION: $@";
 838
 839     # *MUST* be context sensitive due to legacy (DO NOT call search_rs)
 840     defined( $pos = $self->get_column($position_column) )
 841         ? $self->_group_rs->search(
 842             { $position_column => { '!=' => $pos } },
 843           )
 844         : $self->_group_rs
 845     ;
 846 }
 847
 848 # Returns the B<absolute numeric position> of the current object, with the
 849 # first object being at position 1, its sibling at position 2 and so on.
 850 sub _position {
 851     my $self = shift;
 852     return $self->_position_from_value ($self->get_column ($self->position_column) );
 853 }
 854
 855 # This method returns one or more name=>value pairs for limiting a search
 856 # by the grouping column(s).  If the grouping column is not defined then
 857 # this will return an empty list.
 858 sub _grouping_clause {
 859     my( $self ) = @_;
 860     return map {  $_ => $self->get_column($_)  } $self->_grouping_columns();
 861 }
 862
 863 # Returns a list of the column names used for grouping, regardless of whether
 864 # they were specified as an arrayref or a single string, and returns ()
 865 # if there is no grouping.
 866 sub _grouping_columns {
 867     my( $self ) = @_;
 868     my $col = $self->grouping_column();
 869     if (ref $col eq 'ARRAY') {
 870         return @$col;
 871     } elsif ($col) {
 872         return ( $col );
 873     } else {
 874         return ();
 875     }
 876 }
 877
 878 # Returns true if the object is in the group represented by hashref $other
 879 sub _is_in_group {
 880     my ($self, $other) = @_;
 881     my $current = {$self->_grouping_clause};
 882
 883     (
 884       bag_eq(
 885         [ keys %$current ],
 886         [ keys %$other ],
 887       )
 888         and
 889       ! grep {
 890         (
 891           defined( $current->{$_} )
 892             xor
 893           defined( $other->{$_} )
 894         )
 895           or
 896         (
 897           defined $current->{$_}
 898             and
 899           $current->{$_} ne $other->{$_}
 900         )
 901       } keys %$other
 902     ) ? 1 : 0;
 903 }
 904
 905 # This is a short-circuited method, that is used internally by this
 906 # module to update positioning values in isolation (i.e. without
 907 # triggering any of the positioning integrity code).
 908 #
 909 # Some day you might get confronted by datasets that have ambiguous
 910 # positioning data (e.g. duplicate position values within the same group,
 911 # in a table without unique constraints). When manually fixing such data
 912 # keep in mind that you can not invoke L<DBIx::Class::Row/update> like
 913 # you normally would, as it will get confused by the wrong data before
 914 # having a chance to update the ill-defined row. If you really know what
 915 # you are doing use this method which bypasses any hooks introduced by
 916 # this module.
 917 sub _ordered_internal_update {
 918     local $_[0]->result_source->schema->{_ORDERED_INTERNAL_UPDATE} = 1;
 919     shift->update (@_);
 920 }
 921
 922 1;
 923
 924 __END__
 925
 926 =head1 CAVEATS
 927
 928 =head2 Resultset Methods
 929
 930 Note that all Insert/Create/Delete overrides are happening on
 931 L<DBIx::Class::Row> methods only. If you use the
 932 L<DBIx::Class::ResultSet> versions of
 933 L<update|DBIx::Class::ResultSet/update> or
 934 L<delete|DBIx::Class::ResultSet/delete>, all logic present in this
 935 module will be bypassed entirely (possibly resulting in a broken
 936 order-tree). Instead always use the
 937 L<update_all|DBIx::Class::ResultSet/update_all> and
 938 L<delete_all|DBIx::Class::ResultSet/delete_all> methods, which will
 939 invoke the corresponding L<row|DBIx::Class::Row> method on every
 940 member of the given resultset.
 941
 942 =head2 Race Condition on Insert
 943
 944 If a position is not specified for an insert, a position
 945 will be chosen based either on L</_initial_position_value> or
 946 L</_next_position_value>, depending if there are already some
 947 items in the current group. The space of time between the
 948 necessary selects and insert introduces a race condition.
 949 Having unique constraints on your position/group columns,
 950 and using transactions (see L<DBIx::Class::Storage/txn_do>)
 951 will prevent such race conditions going undetected.
 952
 953 =head2 Multiple Moves
 954
 955 If you have multiple same-group result objects already loaded from storage,
 956 you need to be careful when executing C<move_*> operations on them:
 957 without a L</position_column> reload the L</_position_value> of the
 958 "siblings" will be out of sync with the underlying storage.
 959
 960 Starting from version C<0.082800> DBIC will implicitly perform such
 961 reloads when the C<move_*> happens as a part of a transaction
 962 (a good example of such situation is C<< $ordered_resultset->delete_all >>).
 963
 964 If it is not possible for you to wrap the entire call-chain in a transaction,
 965 you will need to call L<DBIx::Class::Row/discard_changes> to get an object
 966 up-to-date before proceeding, otherwise undefined behavior will result.
 967
 968 =head2 Default Values
 969
 970 Using a database defined default_value on one of your group columns
 971 could result in the position not being assigned correctly.
 972
 973 =head1 FURTHER QUESTIONS?
 974
 975 Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
 976
 977 =head1 COPYRIGHT AND LICENSE
 978
 979 This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
 980 by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
 981 redistribute it and/or modify it under the same terms as the
 982 L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.