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 Thats 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.  Default 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 specified 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 result set 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 sibliing.
 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 Return 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.  Undef
 195 is returned 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 foward.  Undef
 217 is returned 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 on position previous in the list.
 240 1 is returned on success, and 0 is returned if the objects is already
 241 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.  1 is returned on
 256 success, and 0 is returned if the object is already the last in the list.
 257
 258 =cut
 259
 260 sub move_next {
 261     my( $self ) = @_;
 262     my $position = $self->get_column( $self->position_column() );
 263     my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
 264     return 0 if ($position==$count);
 265     return $self->move_to( $position + 1 );
 266 }
 267
 268 =head2 move_first
 269
 270   $item->move_first();
 271
 272 Moves the object to the first position.  1 is returned on
 273 success, and 0 is returned if the object is already the first.
 274
 275 =cut
 276
 277 sub move_first {
 278     my( $self ) = @_;
 279     return $self->move_to( 1 );
 280 }
 281
 282 =head2 move_last
 283
 284   $item->move_last();
 285
 286 Moves the object to the very last position.  1 is returned on
 287 success, and 0 is returned if the object is already the last one.
 288
 289 =cut
 290
 291 sub move_last {
 292     my( $self ) = @_;
 293     my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
 294     return $self->move_to( $count );
 295 }
 296
 297 =head2 move_to
 298
 299   $item->move_to( $position );
 300
 301 Moves the object to the specified position.  1 is returned on
 302 success, and 0 is returned if the object is already at the
 303 specified position.
 304
 305 =cut
 306
 307 sub move_to {
 308     my( $self, $to_position ) = @_;
 309     my $position_column = $self->position_column;
 310     my $from_position = $self->get_column( $position_column );
 311     return 0 if ( $to_position < 1 );
 312     return 0 if ( $from_position==$to_position );
 313     my @between = (
 314         ( $from_position < $to_position )
 315         ? ( $from_position+1, $to_position )
 316         : ( $to_position, $from_position-1 )
 317     );
 318     my $rs = $self->result_source->resultset->search({
 319         $position_column => { -between => [ @between ] },
 320         $self->_grouping_clause(),
 321     });
 322     my $op = ($from_position>$to_position) ? '+' : '-';
 323     $rs->update({ $position_column => \"$position_column $op 1" });  #" Sorry, GEdit bug
 324     $self->{_ORDERED_INTERNAL_UPDATE} = 1;
 325     $self->update({ $position_column => $to_position });
 326     return 1;
 327 }
 328
 329
 330
 331 =head2 move_to_group
 332
 333   $item->move_to_group( $group, $position );
 334
 335 Moves the object to the specified position of the specified
 336 group, or to the end of the group if $position is undef.
 337 1 is returned on success, and 0 is returned if the object is
 338 already at the specified position of the specified group.
 339
 340 $group may be specified as a single scalar if only one
 341 grouping column is in use, or as a hashref of column => value pairs
 342 if multiple grouping columns are in use.
 343
 344 =cut
 345
 346 sub move_to_group {
 347     my( $self, $to_group, $to_position ) = @_;
 348
 349     # if we're given a string, turn it into a hashref
 350     unless (ref $to_group eq 'HASH') {
 351         $to_group = {($self->_grouping_columns)[0] => $to_group};
 352     }
 353
 354     my $position_column = $self->position_column;
 355     #my @grouping_columns = $self->_grouping_columns;
 356
 357     return 0 if ( ! defined($to_group) );
 358     return 0 if ( defined($to_position) and $to_position < 1 );
 359     return 0 if ( $self->_is_in_group($to_group)
 360                     and ((not defined($to_position))
 361                             or (defined($to_position) and $self->$position_column==$to_position)
 362                         )
 363                     );
 364
 365     # Move to end of current group and adjust siblings
 366     $self->move_last;
 367
 368     $self->set_columns($to_group);
 369     my $new_group_count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
 370     if (!defined($to_position) or $to_position > $new_group_count) {
 371         $self->{_ORDERED_INTERNAL_UPDATE} = 1;
 372         $self->update({ $position_column => $new_group_count + 1 });
 373     }
 374     else {
 375         my @between = ($to_position, $new_group_count);
 376
 377         my $rs = $self->result_source->resultset->search({
 378             $position_column => { -between => [ @between ] },
 379             $self->_grouping_clause(),
 380         });
 381         $rs->update({ $position_column => \"$position_column + 1" }); #"
 382         $self->{_ORDERED_INTERNAL_UPDATE} = 1;
 383         $self->update({ $position_column => $to_position });
 384     }
 385
 386     return 1;
 387 }
 388
 389 =head2 insert
 390
 391 Overrides the DBIC insert() method by providing a default
 392 position number.  The default will be the number of rows in
 393 the table +1, thus positioning the new record at the last position.
 394
 395 =cut
 396
 397 sub insert {
 398     my $self = shift;
 399     my $position_column = $self->position_column;
 400     $self->set_column( $position_column => $self->result_source->resultset->search( {$self->_grouping_clause()} )->count()+1 )
 401         if (!$self->get_column($position_column));
 402     return $self->next::method( @_ );
 403 }
 404
 405 =head2 update
 406
 407 Overrides the DBIC update() method by checking for a change
 408 to the position and/or group columns.  Movement within a
 409 group or to another group is handled by repositioning
 410 the appropriate siblings.  Position defaults to the end
 411 of a new group if it has been changed to undef.
 412
 413 =cut
 414
 415 sub update {
 416     my $self = shift;
 417
 418     if ($self->{_ORDERED_INTERNAL_UPDATE}) {
 419         delete $self->{_ORDERED_INTERNAL_UPDATE};
 420         return $self->next::method( @_ );
 421     }
 422
 423     $self->set_columns($_[0]) if @_ > 0;
 424     my %changes = $self->get_dirty_columns;
 425     $self->discard_changes;
 426
 427     my $pos_col = $self->position_column;
 428
 429     # if any of our grouping columns have been changed
 430     if (grep {$_} map {exists $changes{$_}} $self->_grouping_columns ) {
 431
 432         # create new_group by taking the current group and inserting changes
 433         my $new_group = {$self->_grouping_clause};
 434         foreach my $col (keys %$new_group) {
 435             if (exists $changes{$col}) {
 436                 $new_group->{$col} = $changes{$col};
 437                 delete $changes{$col}; # don't want to pass this on to next::method
 438             }
 439         }
 440
 441         $self->move_to_group(
 442             $new_group,
 443             exists($changes{$pos_col}) ? delete($changes{$pos_col}) : $self->$pos_col
 444         );
 445     }
 446     elsif (exists $changes{$pos_col}) {
 447         $self->move_to(delete $changes{$pos_col});
 448     }
 449     return $self->next::method( \%changes );
 450 }
 451
 452 =head2 delete
 453
 454 Overrides the DBIC delete() method by first moving the object
 455 to the last position, then deleting it, thus ensuring the
 456 integrity of the positions.
 457
 458 =cut
 459
 460 sub delete {
 461     my $self = shift;
 462     $self->move_last;
 463     return $self->next::method( @_ );
 464 }
 465
 466 =head1 PRIVATE METHODS
 467
 468 These methods are used internally.  You should never have the
 469 need to use them.
 470
 471 =head2 _grouping_clause
 472
 473 This method returns one or more name=>value pairs for limiting a search
 474 by the grouping column(s).  If the grouping column is not
 475 defined then this will return an empty list.
 476
 477 =cut
 478 sub _grouping_clause {
 479     my( $self ) = @_;
 480     return map {  $_ => $self->get_column($_)  } $self->_grouping_columns();
 481 }
 482
 483
 484
 485 =head2 _get_grouping_columns
 486
 487 Returns a list of the column names used for grouping, regardless of whether
 488 they were specified as an arrayref or a single string, and returns ()
 489 if there is no grouping.
 490
 491 =cut
 492 sub _grouping_columns {
 493     my( $self ) = @_;
 494     my $col = $self->grouping_column();
 495     if (ref $col eq 'ARRAY') {
 496         return @$col;
 497     } elsif ($col) {
 498         return ( $col );
 499     } else {
 500         return ();
 501     }
 502 }
 503
 504
 505
 506 =head2 _is_in_group($other)
 507
 508     $item->_is_in_group( {user => 'fred', list => 'work'} )
 509
 510 Returns true if the object is in the group represented by hashref $other
 511 =cut
 512 sub _is_in_group {
 513     my ($self, $other) = @_;
 514     my $current = {$self->_grouping_clause};
 515     return 0 unless (ref $other eq 'HASH') and (keys %$current == keys %$other);
 516     for my $key (keys %$current) {
 517         return 0 unless exists $other->{$key};
 518         return 0 if $current->{$key} ne $other->{$key};
 519     }
 520     return 1;
 521 }
 522
 523
 524 1;
 525 __END__
 526
 527 =head1 BUGS
 528
 529 =head2 Unique Constraints
 530
 531 Unique indexes and constraints on the position column are not
 532 supported at this time.  It would be make sense to support them,
 533 but there are some unexpected database issues that make this
 534 hard to do.  The main problem from the author's view is that
 535 SQLite (the DB engine that we use for testing) does not support
 536 ORDER BY on updates.
 537
 538 =head2 Race Condition on Insert
 539
 540 If a position is not specified for an insert than a position
 541 will be chosen based on COUNT(*)+1.  But, it first selects the
 542 count then inserts the record.  The space of time between select
 543 and insert introduces a race condition.  To fix this we need the
 544 ability to lock tables in DBIC.  I've added an entry in the TODO
 545 about this.
 546
 547 =head2 Multiple Moves
 548
 549 Be careful when issueing move_* methods to multiple objects.  If
 550 you've pre-loaded the objects then when you move one of the objects
 551 the position of the other object will not reflect their new value
 552 until you reload them from the database.
 553
 554 There are times when you will want to move objects as groups, such
 555 as changeing the parent of several objects at once - this directly
 556 conflicts with this problem.  One solution is for us to write a
 557 ResultSet class that supports a parent() method, for example.  Another
 558 solution is to somehow automagically modify the objects that exist
 559 in the current object's result set to have the new position value.
 560
 561 =head1 AUTHOR
 562
 563 Aran Deltac <bluefeet@cpan.org>
 564
 565 =head1 LICENSE
 566
 567 You may distribute this code under the same terms as Perl itself.
 568