lib/DBIx/Class/Ordered.pm

   1 # vim: ts=8:sw=4:sts=4:et
   2 package DBIx::Class::Ordered;
   3 use strict;
   4 use warnings;
   5 use base qw( DBIx::Class );
   6
   7 =head1 NAME
   8
   9 DBIx::Class::Ordered - Modify the position of objects in an ordered list.
  10
  11 =head1 SYNOPSIS
  12
  13 Create a table for your ordered data.
  14
  15   CREATE TABLE items (
  16     item_id INTEGER PRIMARY KEY AUTOINCREMENT,
  17     name TEXT NOT NULL,
  18     position INTEGER NOT NULL
  19   );
  20
  21 In your Schema or DB class add "Ordered" to the top
  22 of the component list.
  23
  24   __PACKAGE__->load_components(qw( Ordered ... ));
  25
  26 Specify the column that stores the position number for
  27 each row.
  28
  29   package My::Item;
  30   __PACKAGE__->position_column('position');
  31
  32 That's it, now you can change the position of your objects.
  33
  34   #!/use/bin/perl
  35   use My::Item;
  36
  37   my $item = My::Item->create({ name=>'Matt S. Trout' });
  38   # If using grouping_column:
  39   my $item = My::Item->create({ name=>'Matt S. Trout', group_id=>1 });
  40
  41   my $rs = $item->siblings();
  42   my @siblings = $item->siblings();
  43
  44   my $sibling;
  45   $sibling = $item->first_sibling();
  46   $sibling = $item->last_sibling();
  47   $sibling = $item->previous_sibling();
  48   $sibling = $item->next_sibling();
  49
  50   $item->move_previous();
  51   $item->move_next();
  52   $item->move_first();
  53   $item->move_last();
  54   $item->move_to( $position );
  55   $item->move_to_group( 'groupname' );
  56   $item->move_to_group( 'groupname', $position );
  57   $item->move_to_group( {group_id=>'groupname', 'other_group_id=>'othergroupname'} );
  58   $item->move_to_group( {group_id=>'groupname', 'other_group_id=>'othergroupname'}, $position );
  59
  60 =head1 DESCRIPTION
  61
  62 This module provides a simple interface for modifying the ordered
  63 position of DBIx::Class objects.
  64
  65 =head1 AUTO UPDATE
  66
  67 All of the move_* methods automatically update the rows involved in
  68 the query.  This is not configurable and is due to the fact that if you
  69 move a record it always causes other records in the list to be updated.
  70
  71 =head1 METHODS
  72
  73 =head2 position_column
  74
  75   __PACKAGE__->position_column('position');
  76
  77 Sets and retrieves the name of the column that stores the
  78 positional value of each record.  Defaults to "position".
  79
  80 =cut
  81
  82 __PACKAGE__->mk_classdata( 'position_column' => 'position' );
  83
  84 =head2 grouping_column
  85
  86   __PACKAGE__->grouping_column('group_id');
  87
  88 This method specifies a column to limit all queries in
  89 this module by.  This effectively allows you to have multiple
  90 ordered lists within the same table.
  91
  92 =cut
  93
  94 __PACKAGE__->mk_classdata( 'grouping_column' );
  95
  96 =head2 siblings
  97
  98   my $rs = $item->siblings();
  99   my @siblings = $item->siblings();
 100
 101 Returns either a resultset or an array of all other objects
 102 excluding the one you called it on.
 103
 104 =cut
 105
 106 sub siblings {
 107     my( $self ) = @_;
 108     my $position_column = $self->position_column;
 109     my $rs = $self->result_source->resultset->search(
 110         {
 111             $position_column => { '!=' => $self->get_column($position_column) },
 112             $self->_grouping_clause(),
 113         },
 114         { order_by => $self->position_column },
 115     );
 116     return $rs->all() if (wantarray());
 117     return $rs;
 118 }
 119
 120 =head2 first_sibling
 121
 122   my $sibling = $item->first_sibling();
 123
 124 Returns the first sibling object, or 0 if the first sibling
 125 is this sibling.
 126
 127 =cut
 128
 129 sub first_sibling {
 130     my( $self ) = @_;
 131     return 0 if ($self->get_column($self->position_column())==1);
 132
 133     return ($self->result_source->resultset->search(
 134         {
 135             $self->position_column => 1,
 136             $self->_grouping_clause(),
 137         },
 138     )->all())[0];
 139 }
 140
 141 =head2 last_sibling
 142
 143   my $sibling = $item->last_sibling();
 144
 145 Returns the last sibling, or 0 if the last sibling is this
 146 sibling.
 147
 148 =cut
 149
 150 sub last_sibling {
 151     my( $self ) = @_;
 152     my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
 153     return 0 if ($self->get_column($self->position_column())==$count);
 154     return ($self->result_source->resultset->search(
 155         {
 156             $self->position_column => $count,
 157             $self->_grouping_clause(),
 158         },
 159     )->all())[0];
 160 }
 161
 162 =head2 previous_sibling
 163
 164   my $sibling = $item->previous_sibling();
 165
 166 Returns the sibling that resides one position back.  Returns undef
 167 if the current object is the first one.
 168
 169 =cut
 170
 171 sub previous_sibling {
 172     my( $self ) = @_;
 173     my $position_column = $self->position_column;
 174     my $position = $self->get_column( $position_column );
 175     return 0 if ($position==1);
 176     return ($self->result_source->resultset->search(
 177         {
 178             $position_column => $position - 1,
 179             $self->_grouping_clause(),
 180         }
 181     )->all())[0];
 182 }
 183
 184 =head2 next_sibling
 185
 186   my $sibling = $item->next_sibling();
 187
 188 Returns the sibling that resides one position forward. Returns undef
 189 if the current object is the last one.
 190
 191 =cut
 192
 193 sub next_sibling {
 194     my( $self ) = @_;
 195     my $position_column = $self->position_column;
 196     my $position = $self->get_column( $position_column );
 197     my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
 198     return 0 if ($position==$count);
 199     return ($self->result_source->resultset->search(
 200         {
 201             $position_column => $position + 1,
 202             $self->_grouping_clause(),
 203         },
 204     )->all())[0];
 205 }
 206
 207 =head2 move_previous
 208
 209   $item->move_previous();
 210
 211 Swaps position with the sibling in the position previous in
 212 the list.  Returns 1 on success, and 0 if the object is
 213 already the first one.
 214
 215 =cut
 216
 217 sub move_previous {
 218     my( $self ) = @_;
 219     my $position = $self->get_column( $self->position_column() );
 220     return $self->move_to( $position - 1 );
 221 }
 222
 223 =head2 move_next
 224
 225   $item->move_next();
 226
 227 Swaps position with the sibling in the next position in the
 228 list.  Returns 1 on success, and 0 if the object is already
 229 the last in the list.
 230
 231 =cut
 232
 233 sub move_next {
 234     my( $self ) = @_;
 235     my $position = $self->get_column( $self->position_column() );
 236     my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
 237     return 0 if ($position==$count);
 238     return $self->move_to( $position + 1 );
 239 }
 240
 241 =head2 move_first
 242
 243   $item->move_first();
 244
 245 Moves the object to the first position in the list.  Returns 1
 246 on success, and 0 if the object is already the first.
 247
 248 =cut
 249
 250 sub move_first {
 251     my( $self ) = @_;
 252     return $self->move_to( 1 );
 253 }
 254
 255 =head2 move_last
 256
 257   $item->move_last();
 258
 259 Moves the object to the last position in the list.  Returns 1
 260 on success, and 0 if the object is already the last one.
 261
 262 =cut
 263
 264 sub move_last {
 265     my( $self ) = @_;
 266     my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
 267     return $self->move_to( $count );
 268 }
 269
 270 =head2 move_to
 271
 272   $item->move_to( $position );
 273
 274 Moves the object to the specified position.  Returns 1 on
 275 success, and 0 if the object is already at the specified
 276 position.
 277
 278 =cut
 279
 280 sub move_to {
 281     my( $self, $to_position ) = @_;
 282     my $position_column = $self->position_column;
 283     my $from_position = $self->get_column( $position_column );
 284     return 0 if ( $to_position < 1 );
 285     return 0 if ( $from_position==$to_position );
 286     my @between = (
 287         ( $from_position < $to_position )
 288         ? ( $from_position+1, $to_position )
 289         : ( $to_position, $from_position-1 )
 290     );
 291     my $rs = $self->result_source->resultset->search({
 292         $position_column => { -between => [ @between ] },
 293         $self->_grouping_clause(),
 294     });
 295     my $op = ($from_position>$to_position) ? '+' : '-';
 296     $rs->update({ $position_column => \"$position_column $op 1" });  #" Sorry, GEdit bug
 297     $self->{_ORDERED_INTERNAL_UPDATE} = 1;
 298     $self->update({ $position_column => $to_position });
 299     return 1;
 300 }
 301
 302
 303
 304 =head2 move_to_group
 305
 306   $item->move_to_group( $group, $position );
 307
 308 Moves the object to the specified position of the specified
 309 group, or to the end of the group if $position is undef.
 310 1 is returned on success, and 0 is returned if the object is
 311 already at the specified position of the specified group.
 312
 313 $group may be specified as a single scalar if only one
 314 grouping column is in use, or as a hashref of column => value pairs
 315 if multiple grouping columns are in use.
 316
 317 =cut
 318
 319 sub move_to_group {
 320     my( $self, $to_group, $to_position ) = @_;
 321
 322     # if we're given a string, turn it into a hashref
 323     unless (ref $to_group eq 'HASH') {
 324         $to_group = {($self->_grouping_columns)[0] => $to_group};
 325     }
 326
 327     my $position_column = $self->position_column;
 328     #my @grouping_columns = $self->_grouping_columns;
 329
 330     return 0 if ( ! defined($to_group) );
 331     return 0 if ( defined($to_position) and $to_position < 1 );
 332     return 0 if ( $self->_is_in_group($to_group)
 333                     and ((not defined($to_position))
 334                             or (defined($to_position) and $self->$position_column==$to_position)
 335                         )
 336                     );
 337
 338     # Move to end of current group and adjust siblings
 339     $self->move_last;
 340
 341     $self->set_columns($to_group);
 342     my $new_group_count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
 343     if (!defined($to_position) or $to_position > $new_group_count) {
 344         $self->{_ORDERED_INTERNAL_UPDATE} = 1;
 345         $self->update({ $position_column => $new_group_count + 1 });
 346     }
 347     else {
 348         my @between = ($to_position, $new_group_count);
 349
 350         my $rs = $self->result_source->resultset->search({
 351             $position_column => { -between => [ @between ] },
 352             $self->_grouping_clause(),
 353         });
 354         $rs->update({ $position_column => \"$position_column + 1" }); #"
 355         $self->{_ORDERED_INTERNAL_UPDATE} = 1;
 356         $self->update({ $position_column => $to_position });
 357     }
 358
 359     return 1;
 360 }
 361
 362 =head2 insert
 363
 364 Overrides the DBIC insert() method by providing a default
 365 position number.  The default will be the number of rows in
 366 the table +1, thus positioning the new record at the last position.
 367
 368 =cut
 369
 370 sub insert {
 371     my $self = shift;
 372     my $position_column = $self->position_column;
 373     $self->set_column( $position_column => $self->result_source->resultset->search( {$self->_grouping_clause()} )->count()+1 )
 374         if (!$self->get_column($position_column));
 375     return $self->next::method( @_ );
 376 }
 377
 378 =head2 update
 379
 380 Overrides the DBIC update() method by checking for a change
 381 to the position and/or group columns.  Movement within a
 382 group or to another group is handled by repositioning
 383 the appropriate siblings.  Position defaults to the end
 384 of a new group if it has been changed to undef.
 385
 386 =cut
 387
 388 sub update {
 389     my $self = shift;
 390
 391     if ($self->{_ORDERED_INTERNAL_UPDATE}) {
 392         delete $self->{_ORDERED_INTERNAL_UPDATE};
 393         return $self->next::method( @_ );
 394     }
 395
 396     $self->set_columns($_[0]) if @_ > 0;
 397     my %changes = $self->get_dirty_columns;
 398     $self->discard_changes;
 399
 400     my $pos_col = $self->position_column;
 401
 402     # if any of our grouping columns have been changed
 403     if (grep {$_} map {exists $changes{$_}} $self->_grouping_columns ) {
 404
 405         # create new_group by taking the current group and inserting changes
 406         my $new_group = {$self->_grouping_clause};
 407         foreach my $col (keys %$new_group) {
 408             if (exists $changes{$col}) {
 409                 $new_group->{$col} = $changes{$col};
 410                 delete $changes{$col}; # don't want to pass this on to next::method
 411             }
 412         }
 413
 414         $self->move_to_group(
 415             $new_group,
 416             exists($changes{$pos_col}) ? delete($changes{$pos_col}) : $self->$pos_col
 417         );
 418     }
 419     elsif (exists $changes{$pos_col}) {
 420         $self->move_to(delete $changes{$pos_col});
 421     }
 422     return $self->next::method( \%changes );
 423 }
 424
 425 =head2 delete
 426
 427 Overrides the DBIC delete() method by first moving the object
 428 to the last position, then deleting it, thus ensuring the
 429 integrity of the positions.
 430
 431 =cut
 432
 433 sub delete {
 434     my $self = shift;
 435     $self->move_last;
 436     return $self->next::method( @_ );
 437 }
 438
 439 =head1 PRIVATE METHODS
 440
 441 These methods are used internally.  You should never have the
 442 need to use them.
 443
 444 =head2 _grouping_clause
 445
 446 This method returns a name=>value pair for limiting a search
 447 by the collection column.  If the collection column is not
 448 defined then this will return an empty list.
 449
 450 =cut
 451 sub _grouping_clause {
 452     my( $self ) = @_;
 453     return map {  $_ => $self->get_column($_)  } $self->_grouping_columns();
 454 }
 455
 456
 457
 458 =head2 _get_grouping_columns
 459
 460 Returns a list of the column names used for grouping, regardless of whether
 461 they were specified as an arrayref or a single string, and returns ()
 462 if there is no grouping.
 463
 464 =cut
 465 sub _grouping_columns {
 466     my( $self ) = @_;
 467     my $col = $self->grouping_column();
 468     if (ref $col eq 'ARRAY') {
 469         return @$col;
 470     } elsif ($col) {
 471         return ( $col );
 472     } else {
 473         return ();
 474     }
 475 }
 476
 477
 478
 479 =head2 _is_in_group($other)
 480
 481     $item->_is_in_group( {user => 'fred', list => 'work'} )
 482
 483 Returns true if the object is in the group represented by hashref $other
 484 =cut
 485 sub _is_in_group {
 486     my ($self, $other) = @_;
 487     my $current = {$self->_grouping_clause};
 488     return 0 unless (ref $other eq 'HASH') and (keys %$current == keys %$other);
 489     for my $key (keys %$current) {
 490         return 0 unless exists $other->{$key};
 491         return 0 if $current->{$key} ne $other->{$key};
 492     }
 493     return 1;
 494 }
 495
 496
 497 1;
 498 __END__
 499
 500 =head1 BUGS
 501
 502 =head2 Unique Constraints
 503
 504 Unique indexes and constraints on the position column are not
 505 supported at this time.  It would be make sense to support them,
 506 but there are some unexpected database issues that make this
 507 hard to do.  The main problem from the author's view is that
 508 SQLite (the DB engine that we use for testing) does not support
 509 ORDER BY on updates.
 510
 511 =head2 Race Condition on Insert
 512
 513 If a position is not specified for an insert than a position
 514 will be chosen based on COUNT(*)+1.  But, it first selects the
 515 count, and then inserts the record.  The space of time between select
 516 and insert introduces a race condition.  To fix this we need the
 517 ability to lock tables in DBIC.  I've added an entry in the TODO
 518 about this.
 519
 520 =head2 Multiple Moves
 521
 522 Be careful when issueing move_* methods to multiple objects.  If
 523 you've pre-loaded the objects then when you move one of the objects
 524 the position of the other object will not reflect their new value
 525 until you reload them from the database.
 526
 527 There are times when you will want to move objects as groups, such
 528 as changeing the parent of several objects at once - this directly
 529 conflicts with this problem.  One solution is for us to write a
 530 ResultSet class that supports a parent() method, for example.  Another
 531 solution is to somehow automagically modify the objects that exist
 532 in the current object's result set to have the new position value.
 533
 534 =head1 AUTHOR
 535
 536 Aran Deltac <bluefeet@cpan.org>
 537
 538 =head1 LICENSE
 539
 540 You may distribute this code under the same terms as Perl itself.
 541