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