Commit | Line | Data |
118e6b96 |
1 | # vim: ts=8:sw=4:sts=4:et |
a733c37f |
2 | package DBIx::Class::Ordered; |
118e6b96 |
3 | use strict; |
4 | use warnings; |
5 | use base qw( DBIx::Class ); |
6 | |
7 | =head1 NAME |
8 | |
a733c37f |
9 | DBIx::Class::Ordered - Modify the position of objects in an ordered list. |
118e6b96 |
10 | |
11 | =head1 SYNOPSIS |
12 | |
a733c37f |
13 | Create a table for your ordered data. |
118e6b96 |
14 | |
a733c37f |
15 | CREATE TABLE items ( |
16 | item_id INTEGER PRIMARY KEY AUTOINCREMENT, |
118e6b96 |
17 | name TEXT NOT NULL, |
18 | position INTEGER NOT NULL |
19 | ); |
169bb185 |
20 | # Optional: group_id INTEGER NOT NULL |
118e6b96 |
21 | |
a733c37f |
22 | In your Schema or DB class add Ordered to the top |
118e6b96 |
23 | of the component list. |
24 | |
a733c37f |
25 | __PACKAGE__->load_components(qw( Ordered ... )); |
118e6b96 |
26 | |
27 | Specify the column that stores the position number for |
28 | each row. |
29 | |
a733c37f |
30 | package My::Item; |
118e6b96 |
31 | __PACKAGE__->position_column('position'); |
a733c37f |
32 | __PACKAGE__->grouping_column('group_id'); # optional |
118e6b96 |
33 | |
34 | Thats it, now you can change the position of your objects. |
35 | |
36 | #!/use/bin/perl |
a733c37f |
37 | use My::Item; |
118e6b96 |
38 | |
a733c37f |
39 | my $item = My::Item->create({ name=>'Matt S. Trout' }); |
40 | # If using grouping_column: |
41 | my $item = My::Item->create({ name=>'Matt S. Trout', group_id=>1 }); |
118e6b96 |
42 | |
a733c37f |
43 | my $rs = $item->siblings(); |
44 | my @siblings = $item->siblings(); |
118e6b96 |
45 | |
46 | my $sibling; |
a733c37f |
47 | $sibling = $item->first_sibling(); |
48 | $sibling = $item->last_sibling(); |
49 | $sibling = $item->previous_sibling(); |
50 | $sibling = $item->next_sibling(); |
118e6b96 |
51 | |
a733c37f |
52 | $item->move_previous(); |
53 | $item->move_next(); |
54 | $item->move_first(); |
55 | $item->move_last(); |
56 | $item->move_to( $position ); |
118e6b96 |
57 | |
58 | =head1 DESCRIPTION |
59 | |
a733c37f |
60 | This module provides a simple interface for modifying the ordered |
61 | position of DBIx::Class objects. |
118e6b96 |
62 | |
133dd22a |
63 | =head1 AUTO UPDATE |
64 | |
65 | All of the move_* methods automatically update the rows involved in |
66 | the query. This is not configurable and is due to the fact that if you |
67 | move a record it always causes other records in the list to be updated. |
68 | |
118e6b96 |
69 | =head1 METHODS |
70 | |
71 | =head2 position_column |
72 | |
73 | __PACKAGE__->position_column('position'); |
74 | |
75 | Sets and retrieves the name of the column that stores the |
76 | positional value of each record. Default to "position". |
77 | |
78 | =cut |
79 | |
80 | __PACKAGE__->mk_classdata( 'position_column' => 'position' ); |
81 | |
a733c37f |
82 | =head2 grouping_column |
133dd22a |
83 | |
a733c37f |
84 | __PACKAGE__->grouping_column('group_id'); |
133dd22a |
85 | |
86 | This method specified a column to limit all queries in |
87 | this module by. This effectively allows you to have multiple |
a733c37f |
88 | ordered lists within the same table. |
133dd22a |
89 | |
90 | =cut |
91 | |
a733c37f |
92 | __PACKAGE__->mk_classdata( 'grouping_column' ); |
133dd22a |
93 | |
118e6b96 |
94 | =head2 siblings |
95 | |
a733c37f |
96 | my $rs = $item->siblings(); |
97 | my @siblings = $item->siblings(); |
118e6b96 |
98 | |
99 | Returns either a result set or an array of all other objects |
100 | excluding the one you called it on. |
101 | |
102 | =cut |
103 | |
104 | sub siblings { |
105 | my( $self ) = @_; |
106 | my $position_column = $self->position_column; |
a9cdbec2 |
107 | my $rs = $self->result_source->resultset->search( |
7a76f44c |
108 | { |
109 | $position_column => { '!=' => $self->get_column($position_column) }, |
a733c37f |
110 | $self->_grouping_clause(), |
7a76f44c |
111 | }, |
118e6b96 |
112 | { order_by => $self->position_column }, |
113 | ); |
7a76f44c |
114 | return $rs->all() if (wantarray()); |
115 | return $rs; |
118e6b96 |
116 | } |
117 | |
118 | =head2 first_sibling |
119 | |
a733c37f |
120 | my $sibling = $item->first_sibling(); |
118e6b96 |
121 | |
5faa95af |
122 | Returns the first sibling object, or 0 if the first sibling |
123 | is this sibliing. |
118e6b96 |
124 | |
125 | =cut |
126 | |
127 | sub first_sibling { |
128 | my( $self ) = @_; |
5faa95af |
129 | return 0 if ($self->get_column($self->position_column())==1); |
fa6b598f |
130 | |
a9cdbec2 |
131 | return ($self->result_source->resultset->search( |
132 | { |
133 | $self->position_column => 1, |
a733c37f |
134 | $self->_grouping_clause(), |
a9cdbec2 |
135 | }, |
118e6b96 |
136 | )->all())[0]; |
137 | } |
138 | |
139 | =head2 last_sibling |
140 | |
a733c37f |
141 | my $sibling = $item->last_sibling(); |
118e6b96 |
142 | |
5faa95af |
143 | Return the last sibling, or 0 if the last sibling is this |
144 | sibling. |
118e6b96 |
145 | |
146 | =cut |
147 | |
148 | sub last_sibling { |
149 | my( $self ) = @_; |
a733c37f |
150 | my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count(); |
5faa95af |
151 | return 0 if ($self->get_column($self->position_column())==$count); |
a9cdbec2 |
152 | return ($self->result_source->resultset->search( |
153 | { |
154 | $self->position_column => $count, |
a733c37f |
155 | $self->_grouping_clause(), |
a9cdbec2 |
156 | }, |
118e6b96 |
157 | )->all())[0]; |
158 | } |
159 | |
160 | =head2 previous_sibling |
161 | |
a733c37f |
162 | my $sibling = $item->previous_sibling(); |
118e6b96 |
163 | |
a733c37f |
164 | Returns the sibling that resides one position back. Undef |
118e6b96 |
165 | is returned if the current object is the first one. |
166 | |
167 | =cut |
168 | |
169 | sub previous_sibling { |
170 | my( $self ) = @_; |
171 | my $position_column = $self->position_column; |
707cbb2d |
172 | my $position = $self->get_column( $position_column ); |
173 | return 0 if ($position==1); |
3ffca97b |
174 | return ($self->result_source->resultset->search( |
7a76f44c |
175 | { |
707cbb2d |
176 | $position_column => $position - 1, |
a733c37f |
177 | $self->_grouping_clause(), |
707cbb2d |
178 | } |
118e6b96 |
179 | )->all())[0]; |
180 | } |
181 | |
182 | =head2 next_sibling |
183 | |
a733c37f |
184 | my $sibling = $item->next_sibling(); |
118e6b96 |
185 | |
a733c37f |
186 | Returns the sibling that resides one position foward. Undef |
118e6b96 |
187 | is returned if the current object is the last one. |
188 | |
189 | =cut |
190 | |
191 | sub next_sibling { |
192 | my( $self ) = @_; |
193 | my $position_column = $self->position_column; |
707cbb2d |
194 | my $position = $self->get_column( $position_column ); |
a733c37f |
195 | my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count(); |
707cbb2d |
196 | return 0 if ($position==$count); |
133dd22a |
197 | return ($self->result_source->resultset->search( |
7a76f44c |
198 | { |
707cbb2d |
199 | $position_column => $position + 1, |
a733c37f |
200 | $self->_grouping_clause(), |
7a76f44c |
201 | }, |
118e6b96 |
202 | )->all())[0]; |
203 | } |
204 | |
80010e2b |
205 | =head2 move_previous |
118e6b96 |
206 | |
a733c37f |
207 | $item->move_previous(); |
118e6b96 |
208 | |
80010e2b |
209 | Swaps position with the sibling on position previous in the list. |
210 | 1 is returned on success, and 0 is returned if the objects is already |
211 | the first one. |
118e6b96 |
212 | |
213 | =cut |
214 | |
80010e2b |
215 | sub move_previous { |
118e6b96 |
216 | my( $self ) = @_; |
133dd22a |
217 | my $position = $self->get_column( $self->position_column() ); |
218 | return $self->move_to( $position - 1 ); |
118e6b96 |
219 | } |
220 | |
80010e2b |
221 | =head2 move_next |
118e6b96 |
222 | |
a733c37f |
223 | $item->move_next(); |
118e6b96 |
224 | |
80010e2b |
225 | Swaps position with the sibling in the next position. 1 is returned on |
226 | success, and 0 is returned if the object is already the last in the list. |
118e6b96 |
227 | |
228 | =cut |
229 | |
80010e2b |
230 | sub move_next { |
118e6b96 |
231 | my( $self ) = @_; |
133dd22a |
232 | my $position = $self->get_column( $self->position_column() ); |
a733c37f |
233 | my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count(); |
133dd22a |
234 | return 0 if ($position==$count); |
235 | return $self->move_to( $position + 1 ); |
118e6b96 |
236 | } |
237 | |
238 | =head2 move_first |
239 | |
a733c37f |
240 | $item->move_first(); |
118e6b96 |
241 | |
242 | Moves the object to the first position. 1 is returned on |
243 | success, and 0 is returned if the object is already the first. |
244 | |
245 | =cut |
246 | |
247 | sub move_first { |
248 | my( $self ) = @_; |
249 | return $self->move_to( 1 ); |
250 | } |
251 | |
252 | =head2 move_last |
253 | |
a733c37f |
254 | $item->move_last(); |
118e6b96 |
255 | |
256 | Moves the object to the very last position. 1 is returned on |
257 | success, and 0 is returned if the object is already the last one. |
258 | |
259 | =cut |
260 | |
261 | sub move_last { |
262 | my( $self ) = @_; |
a733c37f |
263 | my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count(); |
118e6b96 |
264 | return $self->move_to( $count ); |
265 | } |
266 | |
267 | =head2 move_to |
268 | |
a733c37f |
269 | $item->move_to( $position ); |
118e6b96 |
270 | |
271 | Moves the object to the specified position. 1 is returned on |
272 | success, and 0 is returned if the object is already at the |
273 | specified position. |
274 | |
275 | =cut |
276 | |
277 | sub move_to { |
278 | my( $self, $to_position ) = @_; |
279 | my $position_column = $self->position_column; |
280 | my $from_position = $self->get_column( $position_column ); |
133dd22a |
281 | return 0 if ( $to_position < 1 ); |
282 | return 0 if ( $from_position==$to_position ); |
dc66dea1 |
283 | my @between = ( |
284 | ( $from_position < $to_position ) |
285 | ? ( $from_position+1, $to_position ) |
286 | : ( $to_position, $from_position-1 ) |
287 | ); |
133dd22a |
288 | my $rs = $self->result_source->resultset->search({ |
dc66dea1 |
289 | $position_column => { -between => [ @between ] }, |
a733c37f |
290 | $self->_grouping_clause(), |
118e6b96 |
291 | }); |
292 | my $op = ($from_position>$to_position) ? '+' : '-'; |
fa6b598f |
293 | $rs->update({ $position_column => \"$position_column $op 1" }); #" Sorry, GEdit bug |
79dc353a |
294 | $self->{_ORDERED_INTERNAL_UPDATE} = 1; |
b1c66eea |
295 | $self->update({ $position_column => $to_position }); |
118e6b96 |
296 | return 1; |
297 | } |
298 | |
fa6b598f |
299 | |
300 | |
79dc353a |
301 | =head2 move_to_group |
302 | |
303 | $item->move_to_group( $group, $position ); |
304 | |
305 | Moves the object to the specified position of the specified |
306 | group, or to the end of the group if $position is undef. |
307 | 1 is returned on success, and 0 is returned if the object is |
308 | already at the specified position of the specified group. |
309 | |
fa6b598f |
310 | $group should be supplied as a hashref of column => value pairs, |
311 | e.g. if the grouping columns were 'user' and 'list', |
312 | { user => 'fred', list => 'work' }. |
313 | |
79dc353a |
314 | =cut |
315 | |
316 | sub move_to_group { |
317 | my( $self, $to_group, $to_position ) = @_; |
fa6b598f |
318 | |
319 | # if we're given a string, turn it into a hashref |
320 | unless (ref $to_group eq 'HASH') { |
321 | $to_group = {($self->_grouping_columns)[0] => $to_group}; |
322 | } |
323 | |
79dc353a |
324 | my $position_column = $self->position_column; |
fa6b598f |
325 | #my @grouping_columns = $self->_grouping_columns; |
79dc353a |
326 | |
327 | return 0 if ( ! defined($to_group) ); |
328 | return 0 if ( defined($to_position) and $to_position < 1 ); |
fa6b598f |
329 | return 0 if ( $self->_is_in_group($to_group) |
330 | and ((not defined($to_position)) |
331 | or (defined($to_position) and $self->$position_column==$to_position) |
332 | ) |
333 | ); |
79dc353a |
334 | |
335 | # Move to end of current group and adjust siblings |
336 | $self->move_last; |
337 | |
fa6b598f |
338 | $self->set_columns($to_group); |
79dc353a |
339 | my $new_group_count = $self->result_source->resultset->search({$self->_grouping_clause()})->count(); |
340 | if (!defined($to_position) or $to_position > $new_group_count) { |
341 | $self->{_ORDERED_INTERNAL_UPDATE} = 1; |
342 | $self->update({ $position_column => $new_group_count + 1 }); |
343 | } |
344 | else { |
345 | my @between = ($to_position, $new_group_count); |
346 | |
347 | my $rs = $self->result_source->resultset->search({ |
348 | $position_column => { -between => [ @between ] }, |
349 | $self->_grouping_clause(), |
350 | }); |
fa6b598f |
351 | $rs->update({ $position_column => \"$position_column + 1" }); #" |
79dc353a |
352 | $self->{_ORDERED_INTERNAL_UPDATE} = 1; |
353 | $self->update({ $position_column => $to_position }); |
354 | } |
355 | |
356 | return 1; |
357 | } |
358 | |
118e6b96 |
359 | =head2 insert |
360 | |
361 | Overrides the DBIC insert() method by providing a default |
362 | position number. The default will be the number of rows in |
363 | the table +1, thus positioning the new record at the last position. |
364 | |
365 | =cut |
366 | |
367 | sub insert { |
368 | my $self = shift; |
369 | my $position_column = $self->position_column; |
a733c37f |
370 | $self->set_column( $position_column => $self->result_source->resultset->search( {$self->_grouping_clause()} )->count()+1 ) |
118e6b96 |
371 | if (!$self->get_column($position_column)); |
0a298c73 |
372 | return $self->next::method( @_ ); |
118e6b96 |
373 | } |
374 | |
79dc353a |
375 | =head2 update |
376 | |
377 | Overrides the DBIC update() method by checking for a change |
378 | to the position and/or group columns. Movement within a |
379 | group or to another group is handled by repositioning |
380 | the appropriate siblings. Position defaults to the end |
381 | of a new group if it has been changed to undef. |
382 | |
383 | =cut |
384 | |
385 | sub update { |
386 | my $self = shift; |
387 | |
388 | if ($self->{_ORDERED_INTERNAL_UPDATE}) { |
389 | delete $self->{_ORDERED_INTERNAL_UPDATE}; |
390 | return $self->next::method( @_ ); |
391 | } |
392 | |
393 | $self->set_columns($_[0]) if @_ > 0; |
394 | my %changes = $self->get_dirty_columns; |
395 | $self->discard_changes; |
396 | |
397 | my $pos_col = $self->position_column; |
fa6b598f |
398 | |
399 | # is there a chance in hell of this working? |
400 | # if any of our grouping columns have been changed |
401 | $DB::single=1; |
402 | if (grep {$_} map {exists $changes{$_}} $self->_grouping_columns ) { |
403 | |
404 | # create new_group by taking the current group and inserting changes |
405 | my $new_group = {$self->_grouping_clause}; |
406 | foreach my $col (keys %$new_group) { |
407 | if (exists $changes{$col}) { |
408 | $new_group->{$col} = $changes{$col}; |
409 | delete $changes{$col}; # don't want to pass this on to next::method |
410 | } |
411 | } |
412 | |
79dc353a |
413 | $self->move_to_group( |
fa6b598f |
414 | $new_group, |
79dc353a |
415 | exists($changes{$pos_col}) ? delete($changes{$pos_col}) : $self->$pos_col |
416 | ); |
417 | } |
418 | elsif (exists $changes{$pos_col}) { |
419 | $self->move_to(delete $changes{$pos_col}); |
420 | } |
421 | return $self->next::method( \%changes ); |
422 | } |
423 | |
118e6b96 |
424 | =head2 delete |
425 | |
426 | Overrides the DBIC delete() method by first moving the object |
427 | to the last position, then deleting it, thus ensuring the |
428 | integrity of the positions. |
429 | |
430 | =cut |
431 | |
432 | sub delete { |
433 | my $self = shift; |
434 | $self->move_last; |
0a298c73 |
435 | return $self->next::method( @_ ); |
118e6b96 |
436 | } |
437 | |
7a76f44c |
438 | =head1 PRIVATE METHODS |
439 | |
440 | These methods are used internally. You should never have the |
441 | need to use them. |
442 | |
a733c37f |
443 | =head2 _grouping_clause |
118e6b96 |
444 | |
fa6b598f |
445 | This method returns one or more name=>value pairs for limiting a search |
446 | by the grouping column(s). If the grouping column is not |
133dd22a |
447 | defined then this will return an empty list. |
118e6b96 |
448 | |
7a76f44c |
449 | =cut |
a733c37f |
450 | sub _grouping_clause { |
169bb185 |
451 | my( $self ) = @_; |
fa6b598f |
452 | return map { $_ => $self->get_column($_) } $self->_grouping_columns(); |
453 | } |
454 | |
455 | |
456 | |
457 | =head2 _get_grouping_columns |
458 | |
459 | Returns a list of the column names used for grouping, regardless of whether |
460 | they were specified as an arrayref or a single string, and even returns () |
461 | if we're not grouping. |
462 | |
463 | =cut |
464 | sub _grouping_columns { |
465 | my( $self ) = @_; |
a733c37f |
466 | my $col = $self->grouping_column(); |
fa6b598f |
467 | if (ref $col eq 'ARRAY') { |
468 | return @$col; |
469 | } elsif ($col) { |
470 | return ( $col ); |
471 | } else { |
472 | return (); |
133dd22a |
473 | } |
7a76f44c |
474 | } |
475 | |
fa6b598f |
476 | |
477 | |
478 | =head2 _is_in_group($other) |
479 | |
480 | $item->_is_in_group( {user => 'fred', list => 'work'} ) |
481 | |
482 | Returns true if the object is in the group represented by hashref $other |
483 | =cut |
484 | sub _is_in_group { |
485 | my ($self, $other) = @_; |
486 | my $current = {$self->_grouping_clause}; |
487 | return 0 unless (ref $other eq 'HASH') and (keys %$current == keys %$other); |
488 | for my $key (keys %$current) { |
489 | return 0 unless exists $other->{$key}; |
490 | return 0 if $current->{$key} ne $other->{$key}; |
491 | } |
492 | return 1; |
493 | } |
494 | |
495 | |
496 | |
497 | |
7a76f44c |
498 | 1; |
499 | __END__ |
118e6b96 |
500 | |
501 | =head1 BUGS |
502 | |
dc66dea1 |
503 | =head2 Unique Constraints |
504 | |
505 | Unique indexes and constraints on the position column are not |
506 | supported at this time. It would be make sense to support them, |
507 | but there are some unexpected database issues that make this |
508 | hard to do. The main problem from the author's view is that |
509 | SQLite (the DB engine that we use for testing) does not support |
510 | ORDER BY on updates. |
511 | |
133dd22a |
512 | =head2 Race Condition on Insert |
513 | |
118e6b96 |
514 | If a position is not specified for an insert than a position |
515 | will be chosen based on COUNT(*)+1. But, it first selects the |
516 | count then inserts the record. The space of time between select |
517 | and insert introduces a race condition. To fix this we need the |
518 | ability to lock tables in DBIC. I've added an entry in the TODO |
519 | about this. |
520 | |
133dd22a |
521 | =head2 Multiple Moves |
522 | |
523 | Be careful when issueing move_* methods to multiple objects. If |
524 | you've pre-loaded the objects then when you move one of the objects |
525 | the position of the other object will not reflect their new value |
526 | until you reload them from the database. |
527 | |
dc66dea1 |
528 | There are times when you will want to move objects as groups, such |
133dd22a |
529 | as changeing the parent of several objects at once - this directly |
530 | conflicts with this problem. One solution is for us to write a |
531 | ResultSet class that supports a parent() method, for example. Another |
532 | solution is to somehow automagically modify the objects that exist |
533 | in the current object's result set to have the new position value. |
534 | |
118e6b96 |
535 | =head1 AUTHOR |
536 | |
537 | Aran Deltac <bluefeet@cpan.org> |
538 | |
539 | =head1 LICENSE |
540 | |
541 | You may distribute this code under the same terms as Perl itself. |
542 | |