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     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 Return 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.  Undef
 164 is returned 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 foward.  Undef
 186 is returned 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 on position previous in the list.
 209 1 is returned on success, and 0 is returned if the objects is already
 210 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.  1 is returned on
 225 success, and 0 is returned if the object is already the last in the list.
 226
 227 =cut
 228
 229 sub move_next {
 230     my( $self ) = @_;
 231     my $position = $self->get_column( $self->position_column() );
 232     my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
 233     return 0 if ($position==$count);
 234     return $self->move_to( $position + 1 );
 235 }
 236
 237 =head2 move_first
 238
 239   $item->move_first();
 240
 241 Moves the object to the first position.  1 is returned on
 242 success, and 0 is returned if the object is already the first.
 243
 244 =cut
 245
 246 sub move_first {
 247     my( $self ) = @_;
 248     return $self->move_to( 1 );
 249 }
 250
 251 =head2 move_last
 252
 253   $item->move_last();
 254
 255 Moves the object to the very last position.  1 is returned on
 256 success, and 0 is returned if the object is already the last one.
 257
 258 =cut
 259
 260 sub move_last {
 261     my( $self ) = @_;
 262     my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
 263     return $self->move_to( $count );
 264 }
 265
 266 =head2 move_to
 267
 268   $item->move_to( $position );
 269
 270 Moves the object to the specified position.  1 is returned on
 271 success, and 0 is returned if the object is already at the
 272 specified position.
 273
 274 =cut
 275
 276 sub move_to {
 277     my( $self, $to_position ) = @_;
 278     my $position_column = $self->position_column;
 279     my $from_position = $self->get_column( $position_column );
 280     return 0 if ( $to_position < 1 );
 281     return 0 if ( $from_position==$to_position );
 282     my $rs = $self->result_source->resultset->search({
 283         -and => [
 284             $position_column =>
 285               { -between => [ $from_position, $to_position ] },
 286         ],
 287         $self->_grouping_clause(),
 288     });
 289     my $op = ($from_position>$to_position) ? '+' : '-';
 290     my $case_stmt = "CASE $position_column \n".
 291                     "  WHEN $from_position THEN $to_position\n".
 292                     "  ELSE $position_column $op 1\n".
 293                     "END";
 294     $rs->update({ $position_column => \$case_stmt });
 295     $self->store_column( $position_column => $to_position );
 296     return 1;
 297 }
 298
 299 =head2 insert
 300
 301 Overrides the DBIC insert() method by providing a default
 302 position number.  The default will be the number of rows in
 303 the table +1, thus positioning the new record at the last position.
 304
 305 =cut
 306
 307 sub insert {
 308     my $self = shift;
 309     my $position_column = $self->position_column;
 310     $self->set_column( $position_column => $self->result_source->resultset->search( {$self->_grouping_clause()} )->count()+1 )
 311         if (!$self->get_column($position_column));
 312     return $self->next::method( @_ );
 313 }
 314
 315 =head2 delete
 316
 317 Overrides the DBIC delete() method by first moving the object
 318 to the last position, then deleting it, thus ensuring the
 319 integrity of the positions.
 320
 321 =cut
 322
 323 sub delete {
 324     my $self = shift;
 325     $self->move_last;
 326     return $self->next::method( @_ );
 327 }
 328
 329 =head1 PRIVATE METHODS
 330
 331 These methods are used internally.  You should never have the
 332 need to use them.
 333
 334 =head2 _grouping_clause
 335
 336 This method returns a name=>value pare for limiting a search
 337 by the collection column.  If the collection column is not
 338 defined then this will return an empty list.
 339
 340 =cut
 341
 342 sub _grouping_clause {
 343     my( $self ) = @_;
 344     my $col = $self->grouping_column();
 345     if ($col) {
 346         return ( $col => $self->get_column($col) );
 347     }
 348     return ();
 349 }
 350
 351 1;
 352 __END__
 353
 354 =head1 BUGS
 355
 356 =head2 Race Condition on Insert
 357
 358 If a position is not specified for an insert than a position
 359 will be chosen based on COUNT(*)+1.  But, it first selects the
 360 count then inserts the record.  The space of time between select
 361 and insert introduces a race condition.  To fix this we need the
 362 ability to lock tables in DBIC.  I've added an entry in the TODO
 363 about this.
 364
 365 =head2 Multiple Moves
 366
 367 Be careful when issueing move_* methods to multiple objects.  If
 368 you've pre-loaded the objects then when you move one of the objects
 369 the position of the other object will not reflect their new value
 370 until you reload them from the database.
 371
 372 The are times when you will want to move objects as groups, such
 373 as changeing the parent of several objects at once - this directly
 374 conflicts with this problem.  One solution is for us to write a
 375 ResultSet class that supports a parent() method, for example.  Another
 376 solution is to somehow automagically modify the objects that exist
 377 in the current object's result set to have the new position value.
 378
 379 =head1 AUTHOR
 380
 381 Aran Deltac <bluefeet@cpan.org>
 382
 383 =head1 LICENSE
 384
 385 You may distribute this code under the same terms as Perl itself.
 386