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 That's 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.  Defaults 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 specifies 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 resultset 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 sibling.
 124
 125 =cut
 126
 127 sub first_sibling {
 128     my( $self ) = @_;
 129     return 0 if ($self->get_column($self->position_column())==1);
 130     return ($self->result_source->resultset->search(
 131         {
 132             $self->position_column => 1,
 133             $self->_grouping_clause(),
 134         },
 135     )->all())[0];
 136 }
 137
 138 =head2 last_sibling
 139
 140   my $sibling = $item->last_sibling();
 141
 142 Returns the last sibling, or 0 if the last sibling is this
 143 sibling.
 144
 145 =cut
 146
 147 sub last_sibling {
 148     my( $self ) = @_;
 149     my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
 150     return 0 if ($self->get_column($self->position_column())==$count);
 151     return ($self->result_source->resultset->search(
 152         {
 153             $self->position_column => $count,
 154             $self->_grouping_clause(),
 155         },
 156     )->all())[0];
 157 }
 158
 159 =head2 previous_sibling
 160
 161   my $sibling = $item->previous_sibling();
 162
 163 Returns the sibling that resides one position back.  Returns undef
 164 if the current object is the first one.
 165
 166 =cut
 167
 168 sub previous_sibling {
 169     my( $self ) = @_;
 170     my $position_column = $self->position_column;
 171     my $position = $self->get_column( $position_column );
 172     return 0 if ($position==1);
 173     return ($self->result_source->resultset->search(
 174         {
 175             $position_column => $position - 1,
 176             $self->_grouping_clause(),
 177         }
 178     )->all())[0];
 179 }
 180
 181 =head2 next_sibling
 182
 183   my $sibling = $item->next_sibling();
 184
 185 Returns the sibling that resides one position forward. Returns undef
 186 if the current object is the last one.
 187
 188 =cut
 189
 190 sub next_sibling {
 191     my( $self ) = @_;
 192     my $position_column = $self->position_column;
 193     my $position = $self->get_column( $position_column );
 194     my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
 195     return 0 if ($position==$count);
 196     return ($self->result_source->resultset->search(
 197         {
 198             $position_column => $position + 1,
 199             $self->_grouping_clause(),
 200         },
 201     )->all())[0];
 202 }
 203
 204 =head2 move_previous
 205
 206   $item->move_previous();
 207
 208 Swaps position with the sibling in the position previous in
 209 the list.  Returns 1 on success, and 0 if the object is
 210 already the first one.
 211
 212 =cut
 213
 214 sub move_previous {
 215     my( $self ) = @_;
 216     my $position = $self->get_column( $self->position_column() );
 217     return $self->move_to( $position - 1 );
 218 }
 219
 220 =head2 move_next
 221
 222   $item->move_next();
 223
 224 Swaps position with the sibling in the next position in the
 225 list.  Returns 1 on success, and 0 if the object is already
 226 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 in the list.  Returns 1
 243 on success, and 0 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 last position in the list.  Returns 1
 257 on success, and 0 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.  Returns 1 on
 272 success, and 0 if the object is already at the specified
 273 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" });
 294     $self->update({ $position_column => $to_position });
 295     return 1;
 296 }
 297
 298 =head2 insert
 299
 300 Overrides the DBIC insert() method by providing a default
 301 position number.  The default will be the number of rows in
 302 the table +1, thus positioning the new record at the last position.
 303
 304 =cut
 305
 306 sub insert {
 307     my $self = shift;
 308     my $position_column = $self->position_column;
 309     $self->set_column( $position_column => $self->result_source->resultset->search( {$self->_grouping_clause()} )->count()+1 )
 310         if (!$self->get_column($position_column));
 311     return $self->next::method( @_ );
 312 }
 313
 314 =head2 delete
 315
 316 Overrides the DBIC delete() method by first moving the object
 317 to the last position, then deleting it, thus ensuring the
 318 integrity of the positions.
 319
 320 =cut
 321
 322 sub delete {
 323     my $self = shift;
 324     $self->move_last;
 325     return $self->next::method( @_ );
 326 }
 327
 328 =head1 PRIVATE METHODS
 329
 330 These methods are used internally.  You should never have the
 331 need to use them.
 332
 333 =head2 _grouping_clause
 334
 335 This method returns a name=>value pair for limiting a search
 336 by the collection column.  If the collection column is not
 337 defined then this will return an empty list.
 338
 339 =cut
 340
 341 sub _grouping_clause {
 342     my( $self ) = @_;
 343     my $col = $self->grouping_column();
 344     if ($col) {
 345         return ( $col => $self->get_column($col) );
 346     }
 347     return ();
 348 }
 349
 350 1;
 351 __END__
 352
 353 =head1 BUGS
 354
 355 =head2 Unique Constraints
 356
 357 Unique indexes and constraints on the position column are not
 358 supported at this time.  It would be make sense to support them,
 359 but there are some unexpected database issues that make this
 360 hard to do.  The main problem from the author's view is that
 361 SQLite (the DB engine that we use for testing) does not support
 362 ORDER BY on updates.
 363
 364 =head2 Race Condition on Insert
 365
 366 If a position is not specified for an insert than a position
 367 will be chosen based on COUNT(*)+1.  But, it first selects the
 368 count, and then inserts the record.  The space of time between select
 369 and insert introduces a race condition.  To fix this we need the
 370 ability to lock tables in DBIC.  I've added an entry in the TODO
 371 about this.
 372
 373 =head2 Multiple Moves
 374
 375 Be careful when issueing move_* methods to multiple objects.  If
 376 you've pre-loaded the objects then when you move one of the objects
 377 the position of the other object will not reflect their new value
 378 until you reload them from the database.
 379
 380 There are times when you will want to move objects as groups, such
 381 as changeing the parent of several objects at once - this directly
 382 conflicts with this problem.  One solution is for us to write a
 383 ResultSet class that supports a parent() method, for example.  Another
 384 solution is to somehow automagically modify the objects that exist
 385 in the current object's result set to have the new position value.
 386
 387 =head1 AUTHOR
 388
 389 Aran Deltac <bluefeet@cpan.org>
 390
 391 =head1 LICENSE
 392
 393 You may distribute this code under the same terms as Perl itself.
 394