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