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 @between = (
 283         ( $from_position < $to_position )
 284         ? ( $from_position+1, $to_position )
 285         : ( $to_position, $from_position-1 )
 286     );
 287     my $rs = $self->result_source->resultset->search({
 288         $position_column => { -between => [ @between ] },
 289         $self->_grouping_clause(),
 290     });
 291     my $op = ($from_position>$to_position) ? '+' : '-';
 292     $rs->update({ $position_column => \"$position_column $op 1" });
 293     $self->update({ $position_column => $to_position });
 294     return 1;
 295 }
 296
 297 =head2 insert
 298
 299 Overrides the DBIC insert() method by providing a default
 300 position number.  The default will be the number of rows in
 301 the table +1, thus positioning the new record at the last position.
 302
 303 =cut
 304
 305 sub insert {
 306     my $self = shift;
 307     my $position_column = $self->position_column;
 308     $self->set_column( $position_column => $self->result_source->resultset->search( {$self->_grouping_clause()} )->count()+1 )
 309         if (!$self->get_column($position_column));
 310     return $self->next::method( @_ );
 311 }
 312
 313 =head2 delete
 314
 315 Overrides the DBIC delete() method by first moving the object
 316 to the last position, then deleting it, thus ensuring the
 317 integrity of the positions.
 318
 319 =cut
 320
 321 sub delete {
 322     my $self = shift;
 323     $self->move_last;
 324     return $self->next::method( @_ );
 325 }
 326
 327 =head1 PRIVATE METHODS
 328
 329 These methods are used internally.  You should never have the
 330 need to use them.
 331
 332 =head2 _grouping_clause
 333
 334 This method returns a name=>value pare for limiting a search
 335 by the collection column.  If the collection column is not
 336 defined then this will return an empty list.
 337
 338 =cut
 339
 340 sub _grouping_clause {
 341     my( $self ) = @_;
 342     my $col = $self->grouping_column();
 343     if ($col) {
 344         return ( $col => $self->get_column($col) );
 345     }
 346     return ();
 347 }
 348
 349 1;
 350 __END__
 351
 352 =head1 BUGS
 353
 354 =head2 Unique Constraints
 355
 356 Unique indexes and constraints on the position column are not
 357 supported at this time.  It would be make sense to support them,
 358 but there are some unexpected database issues that make this
 359 hard to do.  The main problem from the author's view is that
 360 SQLite (the DB engine that we use for testing) does not support
 361 ORDER BY on updates.
 362
 363 =head2 Race Condition on Insert
 364
 365 If a position is not specified for an insert than a position
 366 will be chosen based on COUNT(*)+1.  But, it first selects the
 367 count then inserts the record.  The space of time between select
 368 and insert introduces a race condition.  To fix this we need the
 369 ability to lock tables in DBIC.  I've added an entry in the TODO
 370 about this.
 371
 372 =head2 Multiple Moves
 373
 374 Be careful when issueing move_* methods to multiple objects.  If
 375 you've pre-loaded the objects then when you move one of the objects
 376 the position of the other object will not reflect their new value
 377 until you reload them from the database.
 378
 379 There are times when you will want to move objects as groups, such
 380 as changeing the parent of several objects at once - this directly
 381 conflicts with this problem.  One solution is for us to write a
 382 ResultSet class that supports a parent() method, for example.  Another
 383 solution is to somehow automagically modify the objects that exist
 384 in the current object's result set to have the new position value.
 385
 386 =head1 AUTHOR
 387
 388 Aran Deltac <bluefeet@cpan.org>
 389
 390 =head1 LICENSE
 391
 392 You may distribute this code under the same terms as Perl itself.
 393