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