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 METHODS
  60
  61 =head2 position_column
  62
  63   __PACKAGE__->position_column('position');
  64
  65 Sets and retrieves the name of the column that stores the
  66 positional value of each record.  Default to "position".
  67
  68 =cut
  69
  70 __PACKAGE__->mk_classdata( 'position_column' => 'position' );
  71
  72 =head2 siblings
  73
  74   my $rs = $employee->siblings();
  75   my @siblings = $employee->siblings();
  76
  77 Returns either a result set or an array of all other objects
  78 excluding the one you called it on.
  79
  80 =cut
  81
  82 sub siblings {
  83     my( $self ) = @_;
  84     my $position_column = $self->position_column;
  85     my $rs = $self->search(
  86         {
  87             $position_column => { '!=' => $self->get_column($position_column) },
  88             $self->_parent_clause(),
  89         },
  90         { order_by => $self->position_column },
  91     );
  92     return $rs->all() if (wantarray());
  93     return $rs;
  94 }
  95
  96 =head2 first_sibling
  97
  98   my $sibling = $employee->first_sibling();
  99
 100 Returns the first sibling object.
 101
 102 =cut
 103
 104 sub first_sibling {
 105     my( $self ) = @_;
 106     return ($self->search(
 107         { $self->_parent_clause() },
 108         { rows=>1, order_by => $self->position_column },
 109     )->all())[0];
 110 }
 111
 112 =head2 last_sibling
 113
 114   my $sibling = $employee->last_sibling();
 115
 116 Return the last sibling.
 117
 118 =cut
 119
 120 sub last_sibling {
 121     my( $self ) = @_;
 122     return ($self->search(
 123         { $self->_parent_clause() },
 124         { rows=>1, order_by => $self->position_column.' DESC' },
 125     )->all())[0];
 126 }
 127
 128 =head2 previous_sibling
 129
 130   my $sibling = $employee->previous_sibling();
 131
 132 Returns the sibling that resides one position higher.  Undef
 133 is returned if the current object is the first one.
 134
 135 =cut
 136
 137 sub previous_sibling {
 138     my( $self ) = @_;
 139     my $position_column = $self->position_column;
 140     return ($self->search(
 141         {
 142             $position_column => { '<' => $self->get_column($position_column) },
 143             $self->_parent_clause(),
 144         },
 145         { rows=>1, order_by => $position_column.' DESC' },
 146     )->all())[0];
 147 }
 148
 149 =head2 next_sibling
 150
 151   my $sibling = $employee->next_sibling();
 152
 153 Returns the sibling that resides one position lower.  Undef
 154 is returned if the current object is the last one.
 155
 156 =cut
 157
 158 sub next_sibling {
 159     my( $self ) = @_;
 160     my $position_column = $self->position_column;
 161     return ($self->search(
 162         {
 163             $position_column => { '>' => $self->get_column($position_column) },
 164             $self->_parent_clause(),
 165         },
 166         { rows=>1, order_by => $position_column },
 167     )->all())[0];
 168 }
 169
 170 =head2 move_previous
 171
 172   $employee->move_previous();
 173
 174 Swaps position with the sibling on position previous in the list.
 175 1 is returned on success, and 0 is returned if the objects is already
 176 the first one.
 177
 178 =cut
 179
 180 sub move_previous {
 181     my( $self ) = @_;
 182     my $previous = $self->previous_sibling();
 183     return undef if (!$previous);
 184     my $position_column = $self->position_column;
 185     my $self_position = $self->get_column( $position_column );
 186     $self->set_column( $position_column, $previous->get_column($position_column) );
 187     $previous->set_column( $position_column, $self_position );
 188     $self->update();
 189     $previous->update();
 190     return 1;
 191 }
 192
 193 =head2 move_next
 194
 195   $employee->move_next();
 196
 197 Swaps position with the sibling in the next position.  1 is returned on
 198 success, and 0 is returned if the object is already the last in the list.
 199
 200 =cut
 201
 202 sub move_next {
 203     my( $self ) = @_;
 204     my $next = $self->next_sibling();
 205     return undef if (!$next);
 206     my $position_column = $self->position_column;
 207     my $self_position = $self->get_column( $position_column );
 208     $self->set_column( $position_column, $next->get_column($position_column) );
 209     $next->set_column( $position_column, $self_position );
 210     $self->update();
 211     $next->update();
 212     return 1;
 213 }
 214
 215 =head2 move_first
 216
 217   $employee->move_first();
 218
 219 Moves the object to the first position.  1 is returned on
 220 success, and 0 is returned if the object is already the first.
 221
 222 =cut
 223
 224 sub move_first {
 225     my( $self ) = @_;
 226     return $self->move_to( 1 );
 227 }
 228
 229 =head2 move_last
 230
 231   $employee->move_last();
 232
 233 Moves the object to the very last position.  1 is returned on
 234 success, and 0 is returned if the object is already the last one.
 235
 236 =cut
 237
 238 sub move_last {
 239     my( $self ) = @_;
 240     my $count = $self->search({$self->_parent_clause()})->count();
 241     return $self->move_to( $count );
 242 }
 243
 244 =head2 move_to
 245
 246   $employee->move_to( $position );
 247
 248 Moves the object to the specified position.  1 is returned on
 249 success, and 0 is returned if the object is already at the
 250 specified position.
 251
 252 =cut
 253
 254 sub move_to {
 255     my( $self, $to_position ) = @_;
 256     my $position_column = $self->position_column;
 257     my $from_position = $self->get_column( $position_column );
 258     return undef if ( $from_position==$to_position );
 259     my $rs = $self->search({
 260         -and => [
 261             $position_column => { ($from_position>$to_position?'<':'>') => $from_position },
 262             $position_column => { ($from_position>$to_position?'>=':'<=') => $to_position },
 263         ],
 264         $self->_parent_clause(),
 265     });
 266     my $op = ($from_position>$to_position) ? '+' : '-';
 267     $rs->update({
 268         $position_column => \"$position_column $op 1",
 269     });
 270     $self->set_column( $position_column => $to_position );
 271     $self->update();
 272     return 1;
 273 }
 274
 275 =head2 insert
 276
 277 Overrides the DBIC insert() method by providing a default
 278 position number.  The default will be the number of rows in
 279 the table +1, thus positioning the new record at the last position.
 280
 281 =cut
 282
 283 sub insert {
 284     my $self = shift;
 285     my $position_column = $self->position_column;
 286     $self->set_column( $position_column => $self->search( {$self->_parent_clause()} )->count()+1 )
 287         if (!$self->get_column($position_column));
 288     $self->next::method( @_ );
 289 }
 290
 291 =head2 delete
 292
 293 Overrides the DBIC delete() method by first moving the object
 294 to the last position, then deleting it, thus ensuring the
 295 integrity of the positions.
 296
 297 =cut
 298
 299 sub delete {
 300     my $self = shift;
 301     $self->move_last;
 302     $self->next::method( @_ );
 303 }
 304
 305 =head1 PRIVATE METHODS
 306
 307 These methods are used internally.  You should never have the
 308 need to use them.
 309
 310 =head2 _parent_clause
 311
 312   sub _parent_clause {
 313     my( $self ) = @_;
 314     return ( parent_id => $self->parent_id );
 315   }
 316
 317 This method is a placeholder for you, or another component, to
 318 provide additional limits for all the various queries in this
 319 module.  This allows for more than one positionable list within
 320 the same table since any move_* method will adhere to the clause
 321 that you specify.
 322
 323 =cut
 324
 325 sub _parent_clause {
 326     return ();
 327 }
 328
 329 1;
 330 __END__
 331
 332 =head1 BUGS
 333
 334 If a position is not specified for an insert than a position
 335 will be chosen based on COUNT(*)+1.  But, it first selects the
 336 count then inserts the record.  The space of time between select
 337 and insert introduces a race condition.  To fix this we need the
 338 ability to lock tables in DBIC.  I've added an entry in the TODO
 339 about this.
 340
 341 =head1 AUTHOR
 342
 343 Aran Deltac <bluefeet@cpan.org>
 344
 345 =head1 LICENSE
 346
 347 You may distribute this code under the same terms as Perl itself.
 348