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_previous
 162
 163   $employee->move_previous();
 164
 165 Swaps position with the sibling on position previous in the list.
 166 1 is returned on success, and 0 is returned if the objects is already
 167 the first one.
 168
 169 =cut
 170
 171 sub move_previous {
 172     my( $self ) = @_;
 173     my $previous = $self->previous_sibling();
 174     return undef if (!$previous);
 175     my $position_column = $self->position_column;
 176     my $self_position = $self->get_column( $position_column );
 177     $self->set_column( $position_column, $previous->get_column($position_column) );
 178     $previous->set_column( $position_column, $self_position );
 179     $self->update();
 180     $previous->update();
 181     return 1;
 182 }
 183
 184 =head2 move_next
 185
 186   $employee->move_next();
 187
 188 Swaps position with the sibling in the next position.  1 is returned on
 189 success, and 0 is returned if the object is already the last in the list.
 190
 191 =cut
 192
 193 sub move_next {
 194     my( $self ) = @_;
 195     my $next = $self->next_sibling();
 196     return undef if (!$next);
 197     my $position_column = $self->position_column;
 198     my $self_position = $self->get_column( $position_column );
 199     $self->set_column( $position_column, $next->get_column($position_column) );
 200     $next->set_column( $position_column, $self_position );
 201     $self->update();
 202     $next->update();
 203     return 1;
 204 }
 205
 206 =head2 move_first
 207
 208   $employee->move_first();
 209
 210 Moves the object to the first position.  1 is returned on
 211 success, and 0 is returned if the object is already the first.
 212
 213 =cut
 214
 215 sub move_first {
 216     my( $self ) = @_;
 217     return $self->move_to( 1 );
 218 }
 219
 220 =head2 move_last
 221
 222   $employee->move_last();
 223
 224 Moves the object to the very last position.  1 is returned on
 225 success, and 0 is returned if the object is already the last one.
 226
 227 =cut
 228
 229 sub move_last {
 230     my( $self ) = @_;
 231     my $count = $self->search()->count();
 232     return $self->move_to( $count );
 233 }
 234
 235 =head2 move_to
 236
 237   $employee->move_to( $position );
 238
 239 Moves the object to the specified position.  1 is returned on
 240 success, and 0 is returned if the object is already at the
 241 specified position.
 242
 243 =cut
 244
 245 sub move_to {
 246     my( $self, $to_position ) = @_;
 247     my $position_column = $self->position_column;
 248     my $from_position = $self->get_column( $position_column );
 249     return undef if ( $from_position==$to_position );
 250     my $rs = $self->search({
 251         -and => [
 252             $position_column => { ($from_position>$to_position?'<':'>') => $from_position },
 253             $position_column => { ($from_position>$to_position?'>=':'<=') => $to_position },
 254         ]
 255     });
 256     my $op = ($from_position>$to_position) ? '+' : '-';
 257     $rs->update({
 258         $position_column => \"$position_column $op 1",
 259     });
 260     $self->set_column( $position_column => $to_position );
 261     $self->update();
 262     return 1;
 263 }
 264
 265 =head2 insert
 266
 267 Overrides the DBIC insert() method by providing a default
 268 position number.  The default will be the number of rows in
 269 the table +1, thus positioning the new record at the last position.
 270
 271 =cut
 272
 273 sub insert {
 274     my $self = shift;
 275     my $position_column = $self->position_column;
 276     $self->set_column( $position_column => $self->count()+1 )
 277         if (!$self->get_column($position_column));
 278     $self->next::method( @_ );
 279 }
 280
 281 =head2 delete
 282
 283 Overrides the DBIC delete() method by first moving the object
 284 to the last position, then deleting it, thus ensuring the
 285 integrity of the positions.
 286
 287 =cut
 288
 289 sub delete {
 290     my $self = shift;
 291     $self->move_last;
 292     $self->next::method( @_ );
 293 }
 294
 295 1;
 296 __END__
 297
 298 =head1 TODO
 299
 300 Support foreign keys that cause rows to be members of mini
 301 positionable sets.
 302
 303 =head1 BUGS
 304
 305 If a position is not specified for an insert than a position
 306 will be chosen based on COUNT(*)+1.  But, it first selects the
 307 count then inserts the record.  The space of time between select
 308 and insert introduces a race condition.  To fix this we need the
 309 ability to lock tables in DBIC.  I've added an entry in the TODO
 310 about this.
 311
 312 =head1 AUTHOR
 313
 314 Aran Deltac <bluefeet@cpan.org>
 315
 316 =head1 LICENSE
 317
 318 You may distribute this code under the same terms as Perl itself.
 319