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         { $position_column => { '!=' => $self->get_column($position_column) } },
  87         { order_by => $self->position_column },
  88     );
  89     if (wantarray()) { return $rs->all(); }
  90     else { return $rs; }
  91 }
  92
  93 =head2 first_sibling
  94
  95   my $sibling = $employee->first_sibling();
  96
  97 Returns the first sibling object.
  98
  99 =cut
 100
 101 sub first_sibling {
 102     my( $self ) = @_;
 103     return ($self->search(
 104         {},
 105         { rows=>1, order_by => $self->position_column },
 106     )->all())[0];
 107 }
 108
 109 =head2 last_sibling
 110
 111   my $sibling = $employee->last_sibling();
 112
 113 Return the last sibling.
 114
 115 =cut
 116
 117 sub last_sibling {
 118     my( $self ) = @_;
 119     return ($self->search(
 120         {},
 121         { rows=>1, order_by => $self->position_column.' DESC' },
 122     )->all())[0];
 123 }
 124
 125 =head2 previous_sibling
 126
 127   my $sibling = $employee->previous_sibling();
 128
 129 Returns the sibling that resides one position higher.  Undef
 130 is returned if the current object is the first one.
 131
 132 =cut
 133
 134 sub previous_sibling {
 135     my( $self ) = @_;
 136     my $position_column = $self->position_column;
 137     return ($self->search(
 138         { $position_column => { '<' => $self->get_column($position_column) } },
 139         { rows=>1, order_by => $position_column.' DESC' },
 140     )->all())[0];
 141 }
 142
 143 =head2 next_sibling
 144
 145   my $sibling = $employee->next_sibling();
 146
 147 Returns the sibling that resides one position lower.  Undef
 148 is returned if the current object is the last one.
 149
 150 =cut
 151
 152 sub next_sibling {
 153     my( $self ) = @_;
 154     my $position_column = $self->position_column;
 155     return ($self->search(
 156         { $position_column => { '>' => $self->get_column($position_column) } },
 157         { rows=>1, order_by => $position_column },
 158     )->all())[0];
 159 }
 160
 161 =head2 move_up
 162
 163   $employee->move_up();
 164
 165 Swaps position with the sibling on position higher.  1 is returned on
 166 success, and 0 is returned if the objects is already the first one.
 167
 168 =cut
 169
 170 sub move_up {
 171     my( $self ) = @_;
 172     my $previous = $self->previous_sibling();
 173     return undef if (!$previous);
 174     my $position_column = $self->position_column;
 175     my $self_position = $self->get_column( $position_column );
 176     $self->set_column( $position_column, $previous->get_column($position_column) );
 177     $previous->set_column( $position_column, $self_position );
 178     $self->update();
 179     $previous->update();
 180     return 1;
 181 }
 182
 183 =head2 move_down
 184
 185   $employee->move_down();
 186
 187 Swaps position with the sibling on position lower.  1 is returned on
 188 success, and 0 is returned if the object is already at the last position.
 189
 190 =cut
 191
 192 sub move_down {
 193     my( $self ) = @_;
 194     my $next = $self->next_sibling();
 195     return undef if (!$next);
 196     my $position_column = $self->position_column;
 197     my $self_position = $self->get_column( $position_column );
 198     $self->set_column( $position_column, $next->get_column($position_column) );
 199     $next->set_column( $position_column, $self_position );
 200     $self->update();
 201     $next->update();
 202     return 1;
 203 }
 204
 205 =head2 move_first
 206
 207   $employee->move_first();
 208
 209 Moves the object to the first position.  1 is returned on
 210 success, and 0 is returned if the object is already the first.
 211
 212 =cut
 213
 214 sub move_first {
 215     my( $self ) = @_;
 216     return $self->move_to( 1 );
 217 }
 218
 219 =head2 move_last
 220
 221   $employee->move_last();
 222
 223 Moves the object to the very last position.  1 is returned on
 224 success, and 0 is returned if the object is already the last one.
 225
 226 =cut
 227
 228 sub move_last {
 229     my( $self ) = @_;
 230     my $count = $self->search()->count();
 231     return $self->move_to( $count );
 232 }
 233
 234 =head2 move_to
 235
 236   $employee->move_to( $position );
 237
 238 Moves the object to the specified position.  1 is returned on
 239 success, and 0 is returned if the object is already at the
 240 specified position.
 241
 242 =cut
 243
 244 sub move_to {
 245     my( $self, $to_position ) = @_;
 246     my $position_column = $self->position_column;
 247     my $from_position = $self->get_column( $position_column );
 248     return undef if ( $from_position==$to_position );
 249     my $rs = $self->search({
 250         -and => [
 251             $position_column => { ($from_position>$to_position?'<':'>') => $from_position },
 252             $position_column => { ($from_position>$to_position?'>=':'<=') => $to_position },
 253         ]
 254     });
 255     my $op = ($from_position>$to_position) ? '+' : '-';
 256     $rs->update({
 257         $position_column => \"$position_column $op 1",
 258     });
 259     $self->set_column( $position_column => $to_position );
 260     $self->update();
 261     return 1;
 262 }
 263
 264 =head2 insert
 265
 266 Overrides the DBIC insert() method by providing a default
 267 position number.  The default will be the number of rows in
 268 the table +1, thus positioning the new record at the last position.
 269
 270 =cut
 271
 272 sub insert {
 273     my $self = shift;
 274     my $position_column = $self->position_column;
 275     $self->set_column( $position_column => $self->count()+1 )
 276         if (!$self->get_column($position_column));
 277     $self->next::method( @_ );
 278 }
 279
 280 =head2 delete
 281
 282 Overrides the DBIC delete() method by first moving the object
 283 to the last position, then deleting it, thus ensuring the
 284 integrity of the positions.
 285
 286 =cut
 287
 288 sub delete {
 289     my $self = shift;
 290     $self->move_last;
 291     $self->next::method( @_ );
 292 }
 293
 294 1;
 295 __END__
 296
 297 =head1 TODO
 298
 299 Support foreign keys that cause rows to be members of mini
 300 positionable sets.
 301
 302 =head1 BUGS
 303
 304 If a position is not specified for an insert than a position
 305 will be chosen based on COUNT(*)+1.  But, it first selects the
 306 count then inserts the record.  The space of time between select
 307 and insert introduces a race condition.  To fix this we need the
 308 ability to lock tables in DBIC.  I've added an entry in the TODO
 309 about this.
 310
 311 =head1 AUTHOR
 312
 313 Aran Deltac <bluefeet@cpan.org>
 314
 315 =head1 LICENSE
 316
 317 You may distribute this code under the same terms as Perl itself.
 318