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