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_previous();
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
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 );
186 $employee->move_next();
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.
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 );
208 $employee->move_first();
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.
217 return $self->move_to( 1 );
222 $employee->move_last();
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.
231 my $count = $self->search()->count();
232 return $self->move_to( $count );
237 $employee->move_to( $position );
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
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({
252 $position_column => { ($from_position>$to_position?'<':'>') => $from_position },
253 $position_column => { ($from_position>$to_position?'>=':'<=') => $to_position },
256 my $op = ($from_position>$to_position) ? '+' : '-';
258 $position_column => \"$position_column $op 1",
260 $self->set_column( $position_column => $to_position );
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.
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( @_ );
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.
292 $self->next::method( @_ );
300 Support foreign keys that cause rows to be members of mini
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
314 Aran Deltac <bluefeet@cpan.org>
318 You may distribute this code under the same terms as Perl itself.