1 # vim: ts=8:sw=4:sts=4:et
2 package DBIx::Class::Positioned;
5 use base qw( DBIx::Class );
9 DBIx::Class::Positioned - Modify the position of objects in an ordered list.
13 Create a table for your positionable data.
15 CREATE TABLE employees (
16 employee_id INTEGER PRIMARY KEY AUTOINCREMENT,
18 position INTEGER NOT NULL
21 In your Schema or DB class add Positioned to the top
22 of the component list.
24 __PACKAGE__->load_components(qw( Positioned ... ));
26 Specify the column that stores the position number for
30 __PACKAGE__->position_column('position');
32 Thats it, now you can change the position of your objects.
37 my $employee = My::Employee->create({ name=>'Matt S. Trout' });
39 my $rs = $employee->siblings();
40 my @siblings = $employee->siblings();
43 $sibling = $employee->first_sibling();
44 $sibling = $employee->last_sibling();
45 $sibling = $employee->previous_sibling();
46 $sibling = $employee->next_sibling();
48 $employee->move_previous();
49 $employee->move_next();
50 $employee->move_first();
51 $employee->move_last();
52 $employee->move_to( $position );
56 This module provides a simple interface for modifying the position
57 of DBIx::Class objects.
61 =head2 position_column
63 __PACKAGE__->position_column('position');
65 Sets and retrieves the name of the column that stores the
66 positional value of each record. Default to "position".
70 __PACKAGE__->mk_classdata( 'position_column' => 'position' );
74 my $rs = $employee->siblings();
75 my @siblings = $employee->siblings();
77 Returns either a result set or an array of all other objects
78 excluding the one you called it on.
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 },
89 if (wantarray()) { return $rs->all(); }
95 my $sibling = $employee->first_sibling();
97 Returns the first sibling object.
103 return ($self->search(
105 { rows=>1, order_by => $self->position_column },
111 my $sibling = $employee->last_sibling();
113 Return the last sibling.
119 return ($self->search(
121 { rows=>1, order_by => $self->position_column.' DESC' },
125 =head2 previous_sibling
127 my $sibling = $employee->previous_sibling();
129 Returns the sibling that resides one position higher. Undef
130 is returned if the current object is the first one.
134 sub previous_sibling {
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' },
145 my $sibling = $employee->next_sibling();
147 Returns the sibling that resides one position lower. Undef
148 is returned if the current object is the last one.
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 },
163 $employee->move_up();
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.
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 );
185 $employee->move_down();
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.
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 );
207 $employee->move_first();
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.
216 return $self->move_to( 1 );
221 $employee->move_last();
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.
230 my $count = $self->search()->count();
231 return $self->move_to( $count );
236 $employee->move_to( $position );
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
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({
251 $position_column => { ($from_position>$to_position?'<':'>') => $from_position },
252 $position_column => { ($from_position>$to_position?'>=':'<=') => $to_position },
255 my $op = ($from_position>$to_position) ? '+' : '-';
257 $position_column => \"$position_column $op 1",
259 $self->set_column( $position_column => $to_position );
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.
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( @_ );
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.
291 $self->next::method( @_ );
299 Support foreign keys that cause rows to be members of mini
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
313 Aran Deltac <bluefeet@cpan.org>
317 You may distribute this code under the same terms as Perl itself.