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