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->result_source->resultset->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->result_source->resultset->search(
 125         {
 126             $self->position_column => 1,
 127             $self->_collection_clause(),
 128         },
 129     )->all())[0];
 130 }
 131
 132 =head2 last_sibling
 133
 134   my $sibling = $employee->last_sibling();
 135
 136 Return the last sibling.
 137
 138 =cut
 139
 140 sub last_sibling {
 141     my( $self ) = @_;
 142     my $count = $self->result_source->resultset->search({$self->_collection_clause()})->count();
 143     return ($self->result_source->resultset->search(
 144         {
 145             $self->position_column => $count,
 146             $self->_collection_clause(),
 147         },
 148     )->all())[0];
 149 }
 150
 151 =head2 previous_sibling
 152
 153   my $sibling = $employee->previous_sibling();
 154
 155 Returns the sibling that resides one position higher.  Undef
 156 is returned if the current object is the first one.
 157
 158 =cut
 159
 160 sub previous_sibling {
 161     my( $self ) = @_;
 162     my $position_column = $self->position_column;
 163     my $position = $self->get_column( $position_column );
 164     return 0 if ($position==1);
 165     return ($self->result_source->resultset->search(
 166         {
 167             $position_column => $position - 1,
 168             $self->_collection_clause(),
 169         }
 170     )->all())[0];
 171 }
 172
 173 =head2 next_sibling
 174
 175   my $sibling = $employee->next_sibling();
 176
 177 Returns the sibling that resides one position lower.  Undef
 178 is returned if the current object is the last one.
 179
 180 =cut
 181
 182 sub next_sibling {
 183     my( $self ) = @_;
 184     my $position_column = $self->position_column;
 185     my $position = $self->get_column( $position_column );
 186     my $count = $self->result_source->resultset->search({$self->_collection_clause()})->count();
 187     return 0 if ($position==$count);
 188     return ($self->result_source->resultset->search(
 189         {
 190             $position_column => $position + 1,
 191             $self->_collection_clause(),
 192         },
 193     )->all())[0];
 194 }
 195
 196 =head2 move_previous
 197
 198   $employee->move_previous();
 199
 200 Swaps position with the sibling on position previous in the list.
 201 1 is returned on success, and 0 is returned if the objects is already
 202 the first one.
 203
 204 =cut
 205
 206 sub move_previous {
 207     my( $self ) = @_;
 208     my $position = $self->get_column( $self->position_column() );
 209     return $self->move_to( $position - 1 );
 210 }
 211
 212 =head2 move_next
 213
 214   $employee->move_next();
 215
 216 Swaps position with the sibling in the next position.  1 is returned on
 217 success, and 0 is returned if the object is already the last in the list.
 218
 219 =cut
 220
 221 sub move_next {
 222     my( $self ) = @_;
 223     my $position = $self->get_column( $self->position_column() );
 224     my $count = $self->result_source->resultset->search({$self->_collection_clause()})->count();
 225     return 0 if ($position==$count);
 226     return $self->move_to( $position + 1 );
 227 }
 228
 229 =head2 move_first
 230
 231   $employee->move_first();
 232
 233 Moves the object to the first position.  1 is returned on
 234 success, and 0 is returned if the object is already the first.
 235
 236 =cut
 237
 238 sub move_first {
 239     my( $self ) = @_;
 240     return $self->move_to( 1 );
 241 }
 242
 243 =head2 move_last
 244
 245   $employee->move_last();
 246
 247 Moves the object to the very last position.  1 is returned on
 248 success, and 0 is returned if the object is already the last one.
 249
 250 =cut
 251
 252 sub move_last {
 253     my( $self ) = @_;
 254     my $count = $self->result_source->resultset->search({$self->_collection_clause()})->count();
 255     return $self->move_to( $count );
 256 }
 257
 258 =head2 move_to
 259
 260   $employee->move_to( $position );
 261
 262 Moves the object to the specified position.  1 is returned on
 263 success, and 0 is returned if the object is already at the
 264 specified position.
 265
 266 =cut
 267
 268 sub move_to {
 269     my( $self, $to_position ) = @_;
 270     my $position_column = $self->position_column;
 271     my $from_position = $self->get_column( $position_column );
 272     return 0 if ( $to_position < 1 );
 273     return 0 if ( $from_position==$to_position );
 274     my $rs = $self->result_source->resultset->search({
 275         -and => [
 276             $position_column => { ($from_position>$to_position?'<':'>') => $from_position },
 277             $position_column => { ($from_position>$to_position?'>=':'<=') => $to_position },
 278         ],
 279         $self->_collection_clause(),
 280     });
 281     my $op = ($from_position>$to_position) ? '+' : '-';
 282     $rs->update({
 283         $position_column => \"$position_column $op 1",
 284     });
 285     $self->set_column( $position_column => $to_position );
 286     $self->update();
 287     return 1;
 288 }
 289
 290 =head2 insert
 291
 292 Overrides the DBIC insert() method by providing a default
 293 position number.  The default will be the number of rows in
 294 the table +1, thus positioning the new record at the last position.
 295
 296 =cut
 297
 298 sub insert {
 299     my $self = shift;
 300     my $position_column = $self->position_column;
 301     $self->set_column( $position_column => $self->result_source->resultset->search( {$self->_collection_clause()} )->count()+1 )
 302         if (!$self->get_column($position_column));
 303     $self->next::method( @_ );
 304 }
 305
 306 =head2 delete
 307
 308 Overrides the DBIC delete() method by first moving the object
 309 to the last position, then deleting it, thus ensuring the
 310 integrity of the positions.
 311
 312 =cut
 313
 314 sub delete {
 315     my $self = shift;
 316     $self->move_last;
 317     $self->next::method( @_ );
 318 }
 319
 320 =head1 PRIVATE METHODS
 321
 322 These methods are used internally.  You should never have the
 323 need to use them.
 324
 325 =head2 _collection_clause
 326
 327 This method returns a name=>value pare for limiting a search
 328 by the collection column.  If the collection column is not
 329 defined then this will return an empty list.
 330
 331 =cut
 332
 333 sub _collection_clause {
 334     my $self = shift;
 335     if ($self->collection_column()) {
 336         return ( $self->collection_column() => $self->get_column($self->collection_column()) );
 337     }
 338     return ();
 339 }
 340
 341 1;
 342 __END__
 343
 344 =head1 BUGS
 345
 346 =head2 Race Condition on Insert
 347
 348 If a position is not specified for an insert than a position
 349 will be chosen based on COUNT(*)+1.  But, it first selects the
 350 count then inserts the record.  The space of time between select
 351 and insert introduces a race condition.  To fix this we need the
 352 ability to lock tables in DBIC.  I've added an entry in the TODO
 353 about this.
 354
 355 =head2 Multiple Moves
 356
 357 Be careful when issueing move_* methods to multiple objects.  If
 358 you've pre-loaded the objects then when you move one of the objects
 359 the position of the other object will not reflect their new value
 360 until you reload them from the database.
 361
 362 The are times when you will want to move objects as groups, such
 363 as changeing the parent of several objects at once - this directly
 364 conflicts with this problem.  One solution is for us to write a
 365 ResultSet class that supports a parent() method, for example.  Another
 366 solution is to somehow automagically modify the objects that exist
 367 in the current object's result set to have the new position value.
 368
 369 =head1 AUTHOR
 370
 371 Aran Deltac <bluefeet@cpan.org>
 372
 373 =head1 LICENSE
 374
 375 You may distribute this code under the same terms as Perl itself.
 376