lib/DBIx/Class/Positioned.pm

   1 # vim: ts=8:sw=4:sts=4:et
   2 package DBIx::Class::Positioned;
   3 use strict;
   4 use warnings;
   5 use base qw( DBIx::Class );
   6
   7 =head1 NAME
   8
   9 DBIx::Class::Positioned - Modify the position of objects in an ordered list.
  10
  11 =head1 SYNOPSIS
  12
  13 Create a table for your positionable data.
  14
  15   CREATE TABLE employees (
  16     employee_id INTEGER PRIMARY KEY AUTOINCREMENT,
  17     name TEXT NOT NULL,
  18     position INTEGER NOT NULL
  19   );
  20
  21 In your Schema or DB class add Positioned to the top
  22 of the component list.
  23
  24   __PACKAGE__->load_components(qw( Positioned ... ));
  25
  26 Specify the column that stores the position number for
  27 each row.
  28
  29   package My::Employee;
  30   __PACKAGE__->position_column('position');
  31
  32 Thats it, now you can change the position of your objects.
  33
  34   #!/use/bin/perl
  35   use My::Employee;
  36
  37   my $employee = My::Employee->create({ name=>'Matt S. Trout' });
  38
  39   my $rs = $employee->siblings();
  40   my @siblings = $employee->siblings();
  41
  42   my $sibling;
  43   $sibling = $employee->first_sibling();
  44   $sibling = $employee->last_sibling();
  45   $sibling = $employee->previous_sibling();
  46   $sibling = $employee->next_sibling();
  47
  48   $employee->move_previous();
  49   $employee->move_next();
  50   $employee->move_first();
  51   $employee->move_last();
  52   $employee->move_to( $position );
  53
  54 =head1 DESCRIPTION
  55
  56 This module provides a simple interface for modifying the position
  57 of DBIx::Class objects.
  58
  59 =head1 AUTO UPDATE
  60
  61 All of the move_* methods automatically update the rows involved in
  62 the query.  This is not configurable and is due to the fact that if you
  63 move a record it always causes other records in the list to be updated.
  64
  65 =head1 METHODS
  66
  67 =head2 position_column
  68
  69   __PACKAGE__->position_column('position');
  70
  71 Sets and retrieves the name of the column that stores the
  72 positional value of each record.  Default to "position".
  73
  74 =cut
  75
  76 __PACKAGE__->mk_classdata( 'position_column' => 'position' );
  77
  78 =head2 collection_column
  79
  80   __PACKAGE__->collection_column('thing_id');
  81
  82 This method specified a column to limit all queries in
  83 this module by.  This effectively allows you to have multiple
  84 positioned lists within the same table.
  85
  86 =cut
  87
  88 __PACKAGE__->mk_classdata( 'collection_column' );
  89
  90 =head2 siblings
  91
  92   my $rs = $employee->siblings();
  93   my @siblings = $employee->siblings();
  94
  95 Returns either a result set or an array of all other objects
  96 excluding the one you called it on.
  97
  98 =cut
  99
 100 sub siblings {
 101     my( $self ) = @_;
 102     my $position_column = $self->position_column;
 103     my $rs = $self->search(
 104         {
 105             $position_column => { '!=' => $self->get_column($position_column) },
 106             $self->_collection_clause(),
 107         },
 108         { order_by => $self->position_column },
 109     );
 110     return $rs->all() if (wantarray());
 111     return $rs;
 112 }
 113
 114 =head2 first_sibling
 115
 116   my $sibling = $employee->first_sibling();
 117
 118 Returns the first sibling object.
 119
 120 =cut
 121
 122 sub first_sibling {
 123     my( $self ) = @_;
 124     return ($self->search(
 125         { $self->_collection_clause() },
 126         { rows=>1, order_by => $self->position_column },
 127     )->all())[0];
 128 }
 129
 130 =head2 last_sibling
 131
 132   my $sibling = $employee->last_sibling();
 133
 134 Return the last sibling.
 135
 136 =cut
 137
 138 sub last_sibling {
 139     my( $self ) = @_;
 140     return ($self->search(
 141         { $self->_collection_clause() },
 142         { rows=>1, order_by => $self->position_column.' DESC' },
 143     )->all())[0];
 144 }
 145
 146 =head2 previous_sibling
 147
 148   my $sibling = $employee->previous_sibling();
 149
 150 Returns the sibling that resides one position higher.  Undef
 151 is returned if the current object is the first one.
 152
 153 =cut
 154
 155 sub previous_sibling {
 156     my( $self ) = @_;
 157     my $position_column = $self->position_column;
 158     my $position = $self->get_column( $position_column );
 159     return 0 if ($position==1);
 160     return ($self->search(
 161         {
 162             $position_column => $position - 1,
 163             $self->_collection_clause(),
 164         }
 165     )->all())[0];
 166 }
 167
 168 =head2 next_sibling
 169
 170   my $sibling = $employee->next_sibling();
 171
 172 Returns the sibling that resides one position lower.  Undef
 173 is returned if the current object is the last one.
 174
 175 =cut
 176
 177 sub next_sibling {
 178     my( $self ) = @_;
 179     my $position_column = $self->position_column;
 180     my $position = $self->get_column( $position_column );
 181     my $count = $self->result_source->resultset->search({$self->_collection_clause()})->count();
 182     return 0 if ($position==$count);
 183     return ($self->result_source->resultset->search(
 184         {
 185             $position_column => $position + 1,
 186             $self->_collection_clause(),
 187         },
 188     )->all())[0];
 189 }
 190
 191 =head2 move_previous
 192
 193   $employee->move_previous();
 194
 195 Swaps position with the sibling on position previous in the list.
 196 1 is returned on success, and 0 is returned if the objects is already
 197 the first one.
 198
 199 =cut
 200
 201 sub move_previous {
 202     my( $self ) = @_;
 203     my $position = $self->get_column( $self->position_column() );
 204     return $self->move_to( $position - 1 );
 205 }
 206
 207 =head2 move_next
 208
 209   $employee->move_next();
 210
 211 Swaps position with the sibling in the next position.  1 is returned on
 212 success, and 0 is returned if the object is already the last in the list.
 213
 214 =cut
 215
 216 sub move_next {
 217     my( $self ) = @_;
 218     my $position = $self->get_column( $self->position_column() );
 219     my $count = $self->result_source->resultset->search({$self->_collection_clause()})->count();
 220     return 0 if ($position==$count);
 221     return $self->move_to( $position + 1 );
 222 }
 223
 224 =head2 move_first
 225
 226   $employee->move_first();
 227
 228 Moves the object to the first position.  1 is returned on
 229 success, and 0 is returned if the object is already the first.
 230
 231 =cut
 232
 233 sub move_first {
 234     my( $self ) = @_;
 235     return $self->move_to( 1 );
 236 }
 237
 238 =head2 move_last
 239
 240   $employee->move_last();
 241
 242 Moves the object to the very last position.  1 is returned on
 243 success, and 0 is returned if the object is already the last one.
 244
 245 =cut
 246
 247 sub move_last {
 248     my( $self ) = @_;
 249     my $count = $self->result_source->resultset->search({$self->_collection_clause()})->count();
 250     return $self->move_to( $count );
 251 }
 252
 253 =head2 move_to
 254
 255   $employee->move_to( $position );
 256
 257 Moves the object to the specified position.  1 is returned on
 258 success, and 0 is returned if the object is already at the
 259 specified position.
 260
 261 =cut
 262
 263 sub move_to {
 264     my( $self, $to_position ) = @_;
 265     my $position_column = $self->position_column;
 266     my $from_position = $self->get_column( $position_column );
 267     return 0 if ( $to_position < 1 );
 268     return 0 if ( $from_position==$to_position );
 269     my $rs = $self->result_source->resultset->search({
 270         -and => [
 271             $position_column => { ($from_position>$to_position?'<':'>') => $from_position },
 272             $position_column => { ($from_position>$to_position?'>=':'<=') => $to_position },
 273         ],
 274         $self->_collection_clause(),
 275     });
 276     my $op = ($from_position>$to_position) ? '+' : '-';
 277     $rs->update({
 278         $position_column => \"$position_column $op 1",
 279     });
 280     $self->set_column( $position_column => $to_position );
 281     $self->update();
 282     return 1;
 283 }
 284
 285 =head2 insert
 286
 287 Overrides the DBIC insert() method by providing a default
 288 position number.  The default will be the number of rows in
 289 the table +1, thus positioning the new record at the last position.
 290
 291 =cut
 292
 293 sub insert {
 294     my $self = shift;
 295     my $position_column = $self->position_column;
 296     $self->set_column( $position_column => $self->result_source->resultset->search( {$self->_collection_clause()} )->count()+1 )
 297         if (!$self->get_column($position_column));
 298     $self->next::method( @_ );
 299 }
 300
 301 =head2 delete
 302
 303 Overrides the DBIC delete() method by first moving the object
 304 to the last position, then deleting it, thus ensuring the
 305 integrity of the positions.
 306
 307 =cut
 308
 309 sub delete {
 310     my $self = shift;
 311     $self->move_last;
 312     $self->next::method( @_ );
 313 }
 314
 315 =head1 PRIVATE METHODS
 316
 317 These methods are used internally.  You should never have the
 318 need to use them.
 319
 320 =head2 _collection_clause
 321
 322 This method returns a name=>value pare for limiting a search
 323 by the collection column.  If the collection column is not
 324 defined then this will return an empty list.
 325
 326 =cut
 327
 328 sub _collection_clause {
 329     my $self = shift;
 330     if ($self->collection_column()) {
 331         return ( $self->collection_column() => $self->get_column($self->collection_column()) );
 332     }
 333     return ();
 334 }
 335
 336 1;
 337 __END__
 338
 339 =head1 BUGS
 340
 341 =head2 Race Condition on Insert
 342
 343 If a position is not specified for an insert than a position
 344 will be chosen based on COUNT(*)+1.  But, it first selects the
 345 count then inserts the record.  The space of time between select
 346 and insert introduces a race condition.  To fix this we need the
 347 ability to lock tables in DBIC.  I've added an entry in the TODO
 348 about this.
 349
 350 =head2 Multiple Moves
 351
 352 Be careful when issueing move_* methods to multiple objects.  If
 353 you've pre-loaded the objects then when you move one of the objects
 354 the position of the other object will not reflect their new value
 355 until you reload them from the database.
 356
 357 The are times when you will want to move objects as groups, such
 358 as changeing the parent of several objects at once - this directly
 359 conflicts with this problem.  One solution is for us to write a
 360 ResultSet class that supports a parent() method, for example.  Another
 361 solution is to somehow automagically modify the objects that exist
 362 in the current object's result set to have the new position value.
 363
 364 =head1 AUTHOR
 365
 366 Aran Deltac <bluefeet@cpan.org>
 367
 368 =head1 LICENSE
 369
 370 You may distribute this code under the same terms as Perl itself.
 371