Commit | Line | Data |
a733c37f |
1 | package DBIx::Class::Ordered; |
118e6b96 |
2 | use strict; |
3 | use warnings; |
4 | use base qw( DBIx::Class ); |
5 | |
6 | =head1 NAME |
7 | |
a733c37f |
8 | DBIx::Class::Ordered - Modify the position of objects in an ordered list. |
118e6b96 |
9 | |
10 | =head1 SYNOPSIS |
11 | |
a733c37f |
12 | Create a table for your ordered data. |
118e6b96 |
13 | |
a733c37f |
14 | CREATE TABLE items ( |
15 | item_id INTEGER PRIMARY KEY AUTOINCREMENT, |
118e6b96 |
16 | name TEXT NOT NULL, |
17 | position INTEGER NOT NULL |
18 | ); |
1d941d67 |
19 | |
e9188247 |
20 | Optionally, add one or more columns to specify groupings, allowing you |
21 | to maintain independent ordered lists within one table: |
22 | |
23 | CREATE TABLE items ( |
24 | item_id INTEGER PRIMARY KEY AUTOINCREMENT, |
25 | name TEXT NOT NULL, |
26 | position INTEGER NOT NULL, |
27 | group_id INTEGER NOT NULL |
28 | ); |
29 | |
30 | Or even |
31 | |
32 | CREATE TABLE items ( |
33 | item_id INTEGER PRIMARY KEY AUTOINCREMENT, |
34 | name TEXT NOT NULL, |
35 | position INTEGER NOT NULL, |
36 | group_id INTEGER NOT NULL, |
37 | other_group_id INTEGER NOT NULL |
38 | ); |
39 | |
a8492531 |
40 | In your Schema or DB class add "Ordered" to the top |
118e6b96 |
41 | of the component list. |
42 | |
a733c37f |
43 | __PACKAGE__->load_components(qw( Ordered ... )); |
118e6b96 |
44 | |
45 | Specify the column that stores the position number for |
46 | each row. |
47 | |
a733c37f |
48 | package My::Item; |
118e6b96 |
49 | __PACKAGE__->position_column('position'); |
1d941d67 |
50 | |
e9188247 |
51 | If you are using one grouping column, specify it as follows: |
52 | |
53 | __PACKAGE__->grouping_column('group_id'); |
54 | |
55 | Or if you have multiple grouping columns: |
56 | |
57 | __PACKAGE__->grouping_column(['group_id', 'other_group_id']); |
58 | |
a8492531 |
59 | That's it, now you can change the position of your objects. |
118e6b96 |
60 | |
61 | #!/use/bin/perl |
a733c37f |
62 | use My::Item; |
d4daee7b |
63 | |
a733c37f |
64 | my $item = My::Item->create({ name=>'Matt S. Trout' }); |
65 | # If using grouping_column: |
66 | my $item = My::Item->create({ name=>'Matt S. Trout', group_id=>1 }); |
d4daee7b |
67 | |
a733c37f |
68 | my $rs = $item->siblings(); |
69 | my @siblings = $item->siblings(); |
d4daee7b |
70 | |
118e6b96 |
71 | my $sibling; |
a733c37f |
72 | $sibling = $item->first_sibling(); |
73 | $sibling = $item->last_sibling(); |
74 | $sibling = $item->previous_sibling(); |
75 | $sibling = $item->next_sibling(); |
d4daee7b |
76 | |
a733c37f |
77 | $item->move_previous(); |
78 | $item->move_next(); |
79 | $item->move_first(); |
80 | $item->move_last(); |
81 | $item->move_to( $position ); |
1d941d67 |
82 | $item->move_to_group( 'groupname' ); |
83 | $item->move_to_group( 'groupname', $position ); |
84 | $item->move_to_group( {group_id=>'groupname', 'other_group_id=>'othergroupname'} ); |
85 | $item->move_to_group( {group_id=>'groupname', 'other_group_id=>'othergroupname'}, $position ); |
118e6b96 |
86 | |
87 | =head1 DESCRIPTION |
88 | |
a733c37f |
89 | This module provides a simple interface for modifying the ordered |
90 | position of DBIx::Class objects. |
118e6b96 |
91 | |
133dd22a |
92 | =head1 AUTO UPDATE |
93 | |
94 | All of the move_* methods automatically update the rows involved in |
95 | the query. This is not configurable and is due to the fact that if you |
96 | move a record it always causes other records in the list to be updated. |
97 | |
118e6b96 |
98 | =head1 METHODS |
99 | |
100 | =head2 position_column |
101 | |
102 | __PACKAGE__->position_column('position'); |
103 | |
104 | Sets and retrieves the name of the column that stores the |
a8492531 |
105 | positional value of each record. Defaults to "position". |
118e6b96 |
106 | |
107 | =cut |
108 | |
109 | __PACKAGE__->mk_classdata( 'position_column' => 'position' ); |
110 | |
a733c37f |
111 | =head2 grouping_column |
133dd22a |
112 | |
a733c37f |
113 | __PACKAGE__->grouping_column('group_id'); |
133dd22a |
114 | |
a8492531 |
115 | This method specifies a column to limit all queries in |
133dd22a |
116 | this module by. This effectively allows you to have multiple |
a733c37f |
117 | ordered lists within the same table. |
133dd22a |
118 | |
119 | =cut |
120 | |
a733c37f |
121 | __PACKAGE__->mk_classdata( 'grouping_column' ); |
133dd22a |
122 | |
bd7ca9e8 |
123 | =head2 null_position_value |
124 | |
125 | __PACKAGE__->null_position_value(undef); |
126 | |
127 | This method specifies a value of L</position_column> which B<would |
128 | never be assigned to a row> during normal operation. When |
129 | a row is moved, its position is set to this value temporarily, so |
130 | that any unique constrainst can not be violated. This value defaults |
131 | to 0, which should work for all cases except when your positions do |
132 | indeed start from 0. |
133 | |
134 | =cut |
135 | |
136 | __PACKAGE__->mk_classdata( 'null_position_value' => 0 ); |
137 | |
118e6b96 |
138 | =head2 siblings |
139 | |
a733c37f |
140 | my $rs = $item->siblings(); |
141 | my @siblings = $item->siblings(); |
118e6b96 |
142 | |
bd7ca9e8 |
143 | Returns an B<ordered> resultset of all other objects in the same |
144 | group excluding the one you called it on. |
118e6b96 |
145 | |
bd7ca9e8 |
146 | The ordering is a backwards-compatibility artifact - if you need |
147 | a resultset with no ordering applied use L</_siblings> |
118e6b96 |
148 | |
bd7ca9e8 |
149 | =cut |
118e6b96 |
150 | sub siblings { |
bd7ca9e8 |
151 | my $self = shift; |
152 | return $self->_siblings->search ({}, { order_by => $self->position_column } ); |
118e6b96 |
153 | } |
154 | |
bd7ca9e8 |
155 | =head2 previous_siblings |
118e6b96 |
156 | |
bd7ca9e8 |
157 | my $prev_rs = $item->previous_siblings(); |
158 | my @prev_siblings = $item->previous_siblings(); |
118e6b96 |
159 | |
bd7ca9e8 |
160 | Returns a resultset of all objects in the same group |
161 | positioned before the object on which this method was called. |
118e6b96 |
162 | |
163 | =cut |
bd7ca9e8 |
164 | sub previous_siblings { |
165 | my $self = shift; |
166 | my $position_column = $self->position_column; |
167 | my $position = $self->get_column ($position_column); |
168 | return ( defined $position |
169 | ? $self->_siblings->search ({ $position_column => { '<', $position } }) |
170 | : $self->_siblings |
171 | ); |
118e6b96 |
172 | } |
173 | |
bd7ca9e8 |
174 | =head2 next_siblings |
118e6b96 |
175 | |
bd7ca9e8 |
176 | my $next_rs = $item->next_siblings(); |
177 | my @next_siblings = $item->next_siblings(); |
118e6b96 |
178 | |
bd7ca9e8 |
179 | Returns a resultset of all objects in the same group |
180 | positioned after the object on which this method was called. |
118e6b96 |
181 | |
182 | =cut |
bd7ca9e8 |
183 | sub next_siblings { |
184 | my $self = shift; |
185 | my $position_column = $self->position_column; |
186 | my $position = $self->get_column ($position_column); |
187 | return ( defined $position |
188 | ? $self->_siblings->search ({ $position_column => { '>', $position } }) |
189 | : $self->_siblings |
190 | ); |
118e6b96 |
191 | } |
192 | |
193 | =head2 previous_sibling |
194 | |
a733c37f |
195 | my $sibling = $item->previous_sibling(); |
118e6b96 |
196 | |
bd7ca9e8 |
197 | Returns the sibling that resides one position back. Returns 0 |
a8492531 |
198 | if the current object is the first one. |
118e6b96 |
199 | |
200 | =cut |
201 | |
202 | sub previous_sibling { |
bd7ca9e8 |
203 | my $self = shift; |
118e6b96 |
204 | my $position_column = $self->position_column; |
bd7ca9e8 |
205 | |
206 | my $psib = $self->previous_siblings->search( |
207 | {}, |
208 | { rows => 1, order_by => { '-desc' => $position_column } }, |
209 | )->single; |
210 | |
211 | return defined $psib ? $psib : 0; |
212 | } |
213 | |
214 | =head2 first_sibling |
215 | |
216 | my $sibling = $item->first_sibling(); |
217 | |
218 | Returns the first sibling object, or 0 if the first sibling |
219 | is this sibling. |
220 | |
221 | =cut |
222 | |
223 | sub first_sibling { |
224 | my $self = shift; |
225 | my $position_column = $self->position_column; |
226 | |
227 | my $fsib = $self->previous_siblings->search( |
228 | {}, |
229 | { rows => 1, order_by => { '-asc' => $position_column } }, |
230 | )->single; |
231 | |
232 | return defined $fsib ? $fsib : 0; |
118e6b96 |
233 | } |
234 | |
235 | =head2 next_sibling |
236 | |
a733c37f |
237 | my $sibling = $item->next_sibling(); |
118e6b96 |
238 | |
bd7ca9e8 |
239 | Returns the sibling that resides one position forward. Returns 0 |
a8492531 |
240 | if the current object is the last one. |
118e6b96 |
241 | |
242 | =cut |
243 | |
244 | sub next_sibling { |
bd7ca9e8 |
245 | my $self = shift; |
246 | my $position_column = $self->position_column; |
247 | my $nsib = $self->next_siblings->search( |
248 | {}, |
249 | { rows => 1, order_by => { '-asc' => $position_column } }, |
250 | )->single; |
251 | |
252 | return defined $nsib ? $nsib : 0; |
253 | } |
254 | |
255 | =head2 last_sibling |
256 | |
257 | my $sibling = $item->last_sibling(); |
258 | |
259 | Returns the last sibling, or 0 if the last sibling is this |
260 | sibling. |
261 | |
262 | =cut |
263 | |
264 | sub last_sibling { |
265 | my $self = shift; |
118e6b96 |
266 | my $position_column = $self->position_column; |
bd7ca9e8 |
267 | my $lsib = $self->next_siblings->search( |
268 | {}, |
269 | { rows => 1, order_by => { '-desc' => $position_column } }, |
270 | )->single; |
271 | |
272 | return defined $lsib ? $lsib : 0; |
118e6b96 |
273 | } |
274 | |
d7c0e320 |
275 | # an optimized method to get the last sibling position value without inflating a row object |
276 | sub _last_sibling_posval { |
82a8f76f |
277 | my $self = shift; |
278 | my $position_column = $self->position_column; |
279 | |
280 | my $cursor = $self->next_siblings->search( |
281 | {}, |
d7c0e320 |
282 | { rows => 1, order_by => { '-desc' => $position_column }, select => $position_column }, |
82a8f76f |
283 | )->cursor; |
284 | |
285 | my ($pos) = $cursor->next; |
286 | return $pos; |
287 | } |
288 | |
80010e2b |
289 | =head2 move_previous |
118e6b96 |
290 | |
a733c37f |
291 | $item->move_previous(); |
118e6b96 |
292 | |
a8492531 |
293 | Swaps position with the sibling in the position previous in |
294 | the list. Returns 1 on success, and 0 if the object is |
295 | already the first one. |
118e6b96 |
296 | |
297 | =cut |
298 | |
80010e2b |
299 | sub move_previous { |
bd7ca9e8 |
300 | my $self = shift; |
301 | return $self->move_to ($self->_position - 1); |
118e6b96 |
302 | } |
303 | |
80010e2b |
304 | =head2 move_next |
118e6b96 |
305 | |
a733c37f |
306 | $item->move_next(); |
118e6b96 |
307 | |
a8492531 |
308 | Swaps position with the sibling in the next position in the |
309 | list. Returns 1 on success, and 0 if the object is already |
310 | the last in the list. |
118e6b96 |
311 | |
312 | =cut |
313 | |
80010e2b |
314 | sub move_next { |
bd7ca9e8 |
315 | my $self = shift; |
d7c0e320 |
316 | return 0 unless defined $self->_last_sibling_posval; # quick way to check for no more siblings |
bd7ca9e8 |
317 | return $self->move_to ($self->_position + 1); |
118e6b96 |
318 | } |
319 | |
320 | =head2 move_first |
321 | |
a733c37f |
322 | $item->move_first(); |
118e6b96 |
323 | |
a8492531 |
324 | Moves the object to the first position in the list. Returns 1 |
325 | on success, and 0 if the object is already the first. |
118e6b96 |
326 | |
327 | =cut |
328 | |
329 | sub move_first { |
bd7ca9e8 |
330 | return shift->move_to( 1 ); |
118e6b96 |
331 | } |
332 | |
333 | =head2 move_last |
334 | |
a733c37f |
335 | $item->move_last(); |
118e6b96 |
336 | |
a8492531 |
337 | Moves the object to the last position in the list. Returns 1 |
338 | on success, and 0 if the object is already the last one. |
118e6b96 |
339 | |
340 | =cut |
341 | |
342 | sub move_last { |
bd7ca9e8 |
343 | my $self = shift; |
d7c0e320 |
344 | my $last_posval = $self->_last_sibling_posval; |
345 | |
346 | return 0 unless defined $last_posval; |
347 | |
348 | return $self->move_to( $self->_position_from_value ($last_posval) ); |
118e6b96 |
349 | } |
350 | |
351 | =head2 move_to |
352 | |
a733c37f |
353 | $item->move_to( $position ); |
118e6b96 |
354 | |
a8492531 |
355 | Moves the object to the specified position. Returns 1 on |
356 | success, and 0 if the object is already at the specified |
357 | position. |
118e6b96 |
358 | |
359 | =cut |
360 | |
361 | sub move_to { |
362 | my( $self, $to_position ) = @_; |
133dd22a |
363 | return 0 if ( $to_position < 1 ); |
118e6b96 |
364 | |
bd7ca9e8 |
365 | my $position_column = $self->position_column; |
366 | |
87b4a877 |
367 | my $guard; |
8f535707 |
368 | |
87b4a877 |
369 | if ($self->is_column_changed ($position_column) ) { |
370 | # something changed our position, we have no idea where we |
371 | # used to be - requery without using discard_changes |
372 | # (we need only a specific column back) |
bd7ca9e8 |
373 | |
87b4a877 |
374 | $guard = $self->result_source->schema->txn_scope_guard; |
b250066f |
375 | |
87b4a877 |
376 | my $cursor = $self->result_source->resultset->search( |
377 | $self->ident_condition, |
378 | { select => $position_column }, |
379 | )->cursor; |
380 | |
381 | my ($pos) = $cursor->next; |
382 | $self->$position_column ($pos); |
383 | delete $self->{_dirty_columns}{$position_column}; |
384 | } |
b250066f |
385 | |
87b4a877 |
386 | my $from_position = $self->_position; |
fa6b598f |
387 | |
87b4a877 |
388 | if ( $from_position == $to_position ) { # FIXME this will not work for non-numeric order |
389 | $guard->commit if $guard; |
390 | return 0; |
391 | } |
392 | |
393 | $guard ||= $self->result_source->schema->txn_scope_guard; |
394 | |
395 | my ($direction, @between); |
396 | if ( $from_position < $to_position ) { |
397 | $direction = -1; |
398 | @between = map { $self->_position_value ($_) } ( $from_position + 1, $to_position ); |
399 | } |
400 | else { |
401 | $direction = 1; |
402 | @between = map { $self->_position_value ($_) } ( $to_position, $from_position - 1 ); |
403 | } |
8f535707 |
404 | |
87b4a877 |
405 | my $new_pos_val = $self->_position_value ($to_position); # record this before the shift |
406 | |
407 | # we need to null-position the moved row if the position column is part of a constraint |
408 | if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $self->result_source->unique_constraints }} ) ) ) { |
409 | $self->_ordered_internal_update({ $position_column => $self->null_position_value }); |
bd7ca9e8 |
410 | } |
87b4a877 |
411 | |
412 | $self->_shift_siblings ($direction, @between); |
413 | $self->_ordered_internal_update({ $position_column => $new_pos_val }); |
414 | |
415 | $guard->commit; |
416 | return 1; |
bd7ca9e8 |
417 | } |
fa6b598f |
418 | |
79dc353a |
419 | =head2 move_to_group |
420 | |
421 | $item->move_to_group( $group, $position ); |
422 | |
423 | Moves the object to the specified position of the specified |
424 | group, or to the end of the group if $position is undef. |
425 | 1 is returned on success, and 0 is returned if the object is |
426 | already at the specified position of the specified group. |
427 | |
1d941d67 |
428 | $group may be specified as a single scalar if only one |
429 | grouping column is in use, or as a hashref of column => value pairs |
430 | if multiple grouping columns are in use. |
fa6b598f |
431 | |
79dc353a |
432 | =cut |
433 | |
434 | sub move_to_group { |
435 | my( $self, $to_group, $to_position ) = @_; |
fa6b598f |
436 | |
bd7ca9e8 |
437 | $self->throw_exception ('move_to_group() expects a group specification') |
438 | unless defined $to_group; |
439 | |
fa6b598f |
440 | # if we're given a string, turn it into a hashref |
441 | unless (ref $to_group eq 'HASH') { |
bd7ca9e8 |
442 | my @gcols = $self->_grouping_columns; |
443 | |
444 | $self->throw_exception ('Single group supplied for a multi-column group identifier') if @gcols > 1; |
445 | $to_group = {$gcols[0] => $to_group}; |
fa6b598f |
446 | } |
447 | |
79dc353a |
448 | my $position_column = $self->position_column; |
79dc353a |
449 | |
79dc353a |
450 | return 0 if ( defined($to_position) and $to_position < 1 ); |
87b4a877 |
451 | |
452 | # check if someone changed the _grouping_columns - this will |
453 | # prevent _is_in_group working, so we need to requery the db |
454 | # for the original values |
455 | my (@dirty_cols, %values, $guard); |
456 | for ($self->_grouping_columns) { |
457 | $values{$_} = $self->get_column ($_); |
458 | push @dirty_cols, $_ if $self->is_column_changed ($_); |
79dc353a |
459 | } |
460 | |
87b4a877 |
461 | # re-query only the dirty columns, and restore them on the |
462 | # object (subsequent code will update them to the correct |
463 | # after-move values) |
464 | if (@dirty_cols) { |
465 | $guard = $self->result_source->schema->txn_scope_guard; |
8f535707 |
466 | |
87b4a877 |
467 | my $cursor = $self->result_source->resultset->search( |
468 | $self->ident_condition, |
469 | { select => \@dirty_cols }, |
470 | )->cursor; |
bd7ca9e8 |
471 | |
87b4a877 |
472 | my @original_values = $cursor->next; |
473 | $self->set_inflated_columns ({ %values, map { $_ => shift @original_values } (@dirty_cols) }); |
474 | } |
bd7ca9e8 |
475 | |
87b4a877 |
476 | if ($self->_is_in_group ($to_group) ) { |
477 | my $ret; |
478 | if (defined $to_position) { |
479 | $ret = $self->move_to ($to_position); |
480 | } |
bd7ca9e8 |
481 | |
87b4a877 |
482 | $guard->commit if $guard; |
483 | return $ret||0; |
484 | } |
bd7ca9e8 |
485 | |
87b4a877 |
486 | $guard ||= $self->result_source->schema->txn_scope_guard; |
487 | |
488 | # Move to end of current group to adjust siblings |
489 | $self->move_last; |
490 | |
491 | $self->set_inflated_columns({ %$to_group, $position_column => undef }); |
492 | my $new_group_last_posval = $self->_last_sibling_posval; |
493 | my $new_group_last_position = $self->_position_from_value ( |
494 | $new_group_last_posval |
495 | ); |
8f535707 |
496 | |
87b4a877 |
497 | if ( not defined($to_position) or $to_position > $new_group_last_position) { |
498 | $self->set_column( |
499 | $position_column => $new_group_last_position |
500 | ? $self->_next_position_value ( $new_group_last_posval ) |
501 | : $self->_initial_position_value |
502 | ); |
bd7ca9e8 |
503 | } |
87b4a877 |
504 | else { |
505 | my $bumped_pos_val = $self->_position_value ($to_position); |
506 | my @between = ($to_position, $new_group_last_position); |
507 | $self->_shift_siblings (1, @between); #shift right |
508 | $self->set_column( $position_column => $bumped_pos_val ); |
509 | } |
510 | |
511 | $self->_ordered_internal_update; |
512 | |
513 | $guard->commit; |
514 | |
515 | return 1; |
79dc353a |
516 | } |
517 | |
118e6b96 |
518 | =head2 insert |
519 | |
520 | Overrides the DBIC insert() method by providing a default |
521 | position number. The default will be the number of rows in |
522 | the table +1, thus positioning the new record at the last position. |
523 | |
524 | =cut |
525 | |
526 | sub insert { |
527 | my $self = shift; |
528 | my $position_column = $self->position_column; |
bd7ca9e8 |
529 | |
530 | unless ($self->get_column($position_column)) { |
d7c0e320 |
531 | my $lsib_posval = $self->_last_sibling_posval; |
bd7ca9e8 |
532 | $self->set_column( |
d7c0e320 |
533 | $position_column => (defined $lsib_posval |
534 | ? $self->_next_position_value ( $lsib_posval ) |
bd7ca9e8 |
535 | : $self->_initial_position_value |
536 | ) |
537 | ); |
538 | } |
539 | |
0a298c73 |
540 | return $self->next::method( @_ ); |
118e6b96 |
541 | } |
542 | |
79dc353a |
543 | =head2 update |
544 | |
545 | Overrides the DBIC update() method by checking for a change |
546 | to the position and/or group columns. Movement within a |
547 | group or to another group is handled by repositioning |
548 | the appropriate siblings. Position defaults to the end |
549 | of a new group if it has been changed to undef. |
550 | |
551 | =cut |
552 | |
553 | sub update { |
554 | my $self = shift; |
555 | |
bd7ca9e8 |
556 | # this is set by _ordered_internal_update() |
557 | return $self->next::method(@_) if $self->{_ORDERED_INTERNAL_UPDATE}; |
79dc353a |
558 | |
bd7ca9e8 |
559 | my $position_column = $self->position_column; |
87b4a877 |
560 | my @ordering_columns = ($self->_grouping_columns, $position_column); |
561 | |
562 | |
563 | # these steps are necessary to keep the external appearance of |
564 | # ->update($upd) so that other things overloading update() will |
565 | # work properly |
566 | my %original_values = $self->get_inflated_columns; |
567 | my %existing_changes = $self->get_dirty_columns; |
568 | |
569 | # See if any of the *supplied* changes would affect the ordering |
570 | # The reason this is so contrived, is that we want to leverage |
571 | # the datatype aware value comparing, while at the same time |
572 | # keep the original value intact (it will be updated later by the |
573 | # corresponding routine) |
574 | |
575 | my %upd = %{shift || {}}; |
576 | my %changes = %existing_changes; |
577 | |
578 | for (@ordering_columns) { |
579 | next unless exists $upd{$_}; |
580 | |
581 | # we do not want to keep propagating this to next::method |
582 | # as it will be a done deal by the time get there |
583 | my $value = delete $upd{$_}; |
584 | $self->set_inflated_columns ({ $_ => $value }); |
585 | |
586 | # see if an update resulted in a dirty column |
587 | # it is important to preserve the old value, as it |
588 | # will be needed to carry on a successfull move() |
589 | # operation without re-querying the database |
590 | if ($self->is_column_changed ($_) && not exists $existing_changes{$_}) { |
591 | $changes{$_} = $value; |
592 | $self->set_inflated_columns ({ $_ => $original_values{$_} }); |
593 | delete $self->{_dirty_columns}{$_}; |
594 | } |
595 | } |
fa6b598f |
596 | |
bd7ca9e8 |
597 | # if nothing group/position related changed - short circuit |
87b4a877 |
598 | if (not grep { exists $changes{$_} } ( @ordering_columns ) ) { |
599 | return $self->next::method( \%upd, @_ ); |
bd7ca9e8 |
600 | } |
fa6b598f |
601 | |
bd7ca9e8 |
602 | { |
8f535707 |
603 | my $guard = $self->result_source->schema->txn_scope_guard; |
604 | |
bd7ca9e8 |
605 | # if any of our grouping columns have been changed |
606 | if (grep { exists $changes{$_} } ($self->_grouping_columns) ) { |
607 | |
608 | # create new_group by taking the current group and inserting changes |
609 | my $new_group = {$self->_grouping_clause}; |
610 | foreach my $col (keys %$new_group) { |
87b4a877 |
611 | $new_group->{$col} = $changes{$col} if exists $changes{$col}; |
fa6b598f |
612 | } |
bd7ca9e8 |
613 | |
614 | $self->move_to_group( |
615 | $new_group, |
616 | (exists $changes{$position_column} |
87b4a877 |
617 | # The FIXME bit contradicts the documentation: POD states that |
618 | # when changing groups without supplying explicit positions in |
619 | # move_to_group(), we push the item to the end of the group. |
620 | # However when I was rewriting this, the position from the old |
621 | # group was clearly passed to the new one |
bd7ca9e8 |
622 | # Probably needs to go away (by ribasushi) |
87b4a877 |
623 | ? $changes{$position_column} # means there was a position change supplied with the update too |
624 | : $self->_position # FIXME! (replace with undef) |
bd7ca9e8 |
625 | ), |
626 | ); |
627 | } |
628 | elsif (exists $changes{$position_column}) { |
87b4a877 |
629 | $self->move_to($changes{$position_column}); |
fa6b598f |
630 | } |
631 | |
8f535707 |
632 | my @res; |
633 | my $want = wantarray(); |
634 | if (not defined $want) { |
87b4a877 |
635 | $self->next::method( \%upd, @_ ); |
8f535707 |
636 | } |
637 | elsif ($want) { |
87b4a877 |
638 | @res = $self->next::method( \%upd, @_ ); |
8f535707 |
639 | } |
640 | else { |
87b4a877 |
641 | $res[0] = $self->next::method( \%upd, @_ ); |
8f535707 |
642 | } |
643 | |
644 | $guard->commit; |
645 | return $want ? @res : $res[0]; |
79dc353a |
646 | } |
79dc353a |
647 | } |
648 | |
118e6b96 |
649 | =head2 delete |
650 | |
651 | Overrides the DBIC delete() method by first moving the object |
bd7ca9e8 |
652 | to the last position, then deleting it, thus ensuring the |
118e6b96 |
653 | integrity of the positions. |
654 | |
655 | =cut |
656 | |
657 | sub delete { |
658 | my $self = shift; |
8f535707 |
659 | |
660 | my $guard = $self->result_source->schema->txn_scope_guard; |
661 | |
662 | $self->move_last; |
663 | |
664 | my @res; |
665 | my $want = wantarray(); |
666 | if (not defined $want) { |
667 | $self->next::method( @_ ); |
bd7ca9e8 |
668 | } |
8f535707 |
669 | elsif ($want) { |
670 | @res = $self->next::method( @_ ); |
671 | } |
672 | else { |
673 | $res[0] = $self->next::method( @_ ); |
674 | } |
675 | |
676 | $guard->commit; |
677 | return $want ? @res : $res[0]; |
bd7ca9e8 |
678 | } |
679 | |
b250066f |
680 | =head1 METHODS FOR EXTENDING ORDERED |
bd7ca9e8 |
681 | |
682 | You would want to override the methods below if you use sparse |
683 | (non-linear) or non-numeric position values. This can be useful |
684 | if you are working with preexisting non-normalised position data, |
685 | or if you need to work with materialized path columns. |
686 | |
687 | =head2 _position |
688 | |
689 | my $num_pos = $item->_position; |
690 | |
b250066f |
691 | Returns the B<absolute numeric position> of the current object, with the |
bd7ca9e8 |
692 | first object being at position 1, its sibling at position 2 and so on. |
693 | By default simply returns the value of L</position_column>. |
694 | |
695 | =cut |
696 | sub _position { |
697 | my $self = shift; |
698 | |
699 | # #the right way to do this |
700 | # return $self->previous_siblings->count + 1; |
701 | |
702 | return $self->get_column ($self->position_column); |
703 | } |
704 | |
d7c0e320 |
705 | =head2 _position_from_value |
706 | |
707 | my $num_pos = $item->_position_of_value ( $pos_value ) |
708 | |
709 | Returns the B<absolute numeric position> of an object with a B<position |
710 | value> set to C<$pos_value>. By default simply returns C<$pos_value>. |
711 | |
712 | =cut |
713 | sub _position_from_value { |
714 | my ($self, $val) = @_; |
715 | |
716 | return 0 unless defined $val; |
717 | |
718 | # #the right way to do this |
719 | # return $self -> _group_rs |
720 | # -> search({ $self->position_column => { '<=', $val } }) |
721 | # -> count |
722 | |
723 | return $val; |
724 | } |
725 | |
bd7ca9e8 |
726 | =head2 _position_value |
727 | |
728 | my $pos_value = $item->_position_value ( $pos ) |
729 | |
b250066f |
730 | Returns the B<value> of L</position_column> of the object at numeric |
bd7ca9e8 |
731 | position C<$pos>. By default simply returns C<$pos>. |
732 | |
733 | =cut |
734 | sub _position_value { |
735 | my ($self, $pos) = @_; |
736 | |
737 | # #the right way to do this (not optimized) |
738 | # my $position_column = $self->position_column; |
739 | # return $self -> _group_rs |
740 | # -> search({}, { order_by => $position_column }) |
741 | # -> slice ( $pos - 1) |
742 | # -> single |
743 | # -> get_column ($position_column); |
744 | |
745 | return $pos; |
746 | } |
747 | |
748 | =head2 _initial_position_value |
749 | |
750 | __PACKAGE__->_initial_position_value(0); |
751 | |
b250066f |
752 | This method specifies a B<value> of L</position_column> which is assigned |
bd7ca9e8 |
753 | to the first inserted element of a group, if no value was supplied at |
754 | insertion time. All subsequent values are derived from this one by |
755 | L</_next_position_value> below. Defaults to 1. |
756 | |
757 | =cut |
758 | |
759 | __PACKAGE__->mk_classdata( '_initial_position_value' => 1 ); |
760 | |
761 | =head2 _next_position_value |
762 | |
763 | my $new_value = $item->_next_position_value ( $position_value ) |
764 | |
b250066f |
765 | Returns a position B<value> that would be considered C<next> with |
bd7ca9e8 |
766 | regards to C<$position_value>. Can be pretty much anything, given |
767 | that C<< $position_value < $new_value >> where C<< < >> is the |
768 | SQL comparison operator (usually works fine on strings). The |
769 | default method expects C<$position_value> to be numeric, and |
770 | returns C<$position_value + 1> |
771 | |
772 | =cut |
773 | sub _next_position_value { |
774 | return $_[1] + 1; |
775 | } |
776 | |
777 | =head2 _shift_siblings |
778 | |
779 | $item->_shift_siblings ($direction, @between) |
780 | |
b250066f |
781 | Shifts all siblings with B<positions values> in the range @between |
782 | (inclusive) by one position as specified by $direction (left if < 0, |
783 | right if > 0). By default simply increments/decrements each |
784 | L<position_column> value by 1, doing so in a way as to not violate |
785 | any existing constraints. |
786 | |
787 | Note that if you override this method and have unique constraints |
788 | including the L<position_column> the shift is not a trivial task. |
789 | Refer to the implementation source of the default method for more |
790 | information. |
bd7ca9e8 |
791 | |
792 | =cut |
793 | sub _shift_siblings { |
794 | my ($self, $direction, @between) = @_; |
795 | return 0 unless $direction; |
796 | |
797 | my $position_column = $self->position_column; |
798 | |
799 | my ($op, $ord); |
800 | if ($direction < 0) { |
801 | $op = '-'; |
802 | $ord = 'asc'; |
803 | } |
804 | else { |
805 | $op = '+'; |
806 | $ord = 'desc'; |
807 | } |
808 | |
809 | my $shift_rs = $self->_group_rs-> search ({ $position_column => { -between => \@between } }); |
810 | |
811 | # some databases (sqlite) are dumb and can not do a blanket |
812 | # increment/decrement. So what we do here is check if the |
813 | # position column is part of a unique constraint, and do a |
814 | # one-by-one update if this is the case |
815 | |
82a8f76f |
816 | my $rsrc = $self->result_source; |
817 | |
818 | if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $rsrc->unique_constraints }} ) ) ) { |
819 | |
820 | my @pcols = $rsrc->primary_columns; |
821 | my $cursor = $shift_rs->search ({}, { order_by => { "-$ord", $position_column }, columns => \@pcols } )->cursor; |
822 | my $rs = $self->result_source->resultset; |
823 | |
824 | while (my @pks = $cursor->next ) { |
825 | |
826 | my $cond; |
827 | for my $i (0.. $#pcols) { |
828 | $cond->{$pcols[$i]} = $pks[$i]; |
829 | } |
bd7ca9e8 |
830 | |
82a8f76f |
831 | $rs->search($cond)->update ({ $position_column => \ "$position_column $op 1" } ); |
bd7ca9e8 |
832 | } |
833 | } |
834 | else { |
835 | $shift_rs->update ({ $position_column => \ "$position_column $op 1" } ); |
836 | } |
118e6b96 |
837 | } |
838 | |
7a76f44c |
839 | =head1 PRIVATE METHODS |
840 | |
841 | These methods are used internally. You should never have the |
842 | need to use them. |
843 | |
bd7ca9e8 |
844 | =head2 _group_rs |
845 | |
b250066f |
846 | This method returns a resultset containing all members of the row |
bd7ca9e8 |
847 | group (including the row itself). |
848 | |
849 | =cut |
850 | sub _group_rs { |
851 | my $self = shift; |
852 | return $self->result_source->resultset->search({$self->_grouping_clause()}); |
853 | } |
854 | |
855 | =head2 _siblings |
856 | |
857 | Returns an unordered resultset of all objects in the same group |
858 | excluding the object you called this method on. |
859 | |
860 | =cut |
861 | sub _siblings { |
862 | my $self = shift; |
863 | my $position_column = $self->position_column; |
864 | return $self->_group_rs->search( |
865 | { $position_column => { '!=' => $self->get_column($position_column) } }, |
866 | ); |
867 | } |
868 | |
a733c37f |
869 | =head2 _grouping_clause |
118e6b96 |
870 | |
bd7ca9e8 |
871 | This method returns one or more name=>value pairs for limiting a search |
87b4a877 |
872 | by the grouping column(s). If the grouping column is not defined then |
873 | this will return an empty list. |
118e6b96 |
874 | |
7a76f44c |
875 | =cut |
a733c37f |
876 | sub _grouping_clause { |
169bb185 |
877 | my( $self ) = @_; |
fa6b598f |
878 | return map { $_ => $self->get_column($_) } $self->_grouping_columns(); |
879 | } |
880 | |
fa6b598f |
881 | =head2 _get_grouping_columns |
882 | |
883 | Returns a list of the column names used for grouping, regardless of whether |
1d941d67 |
884 | they were specified as an arrayref or a single string, and returns () |
885 | if there is no grouping. |
fa6b598f |
886 | |
887 | =cut |
888 | sub _grouping_columns { |
889 | my( $self ) = @_; |
a733c37f |
890 | my $col = $self->grouping_column(); |
fa6b598f |
891 | if (ref $col eq 'ARRAY') { |
892 | return @$col; |
893 | } elsif ($col) { |
894 | return ( $col ); |
895 | } else { |
896 | return (); |
133dd22a |
897 | } |
7a76f44c |
898 | } |
899 | |
bd7ca9e8 |
900 | =head2 _is_in_group |
fa6b598f |
901 | |
902 | $item->_is_in_group( {user => 'fred', list => 'work'} ) |
903 | |
904 | Returns true if the object is in the group represented by hashref $other |
bd7ca9e8 |
905 | |
fa6b598f |
906 | =cut |
907 | sub _is_in_group { |
908 | my ($self, $other) = @_; |
909 | my $current = {$self->_grouping_clause}; |
bd7ca9e8 |
910 | |
911 | no warnings qw/uninitialized/; |
912 | |
913 | return 0 if ( |
914 | join ("\x00", sort keys %$current) |
915 | ne |
916 | join ("\x00", sort keys %$other) |
917 | ); |
fa6b598f |
918 | for my $key (keys %$current) { |
fa6b598f |
919 | return 0 if $current->{$key} ne $other->{$key}; |
920 | } |
921 | return 1; |
922 | } |
923 | |
b250066f |
924 | =head2 _ordered_internal_update |
925 | |
926 | This is a short-circuited method, that is used internally by this |
927 | module to update positioning values in isolation (i.e. without |
928 | triggering any of the positioning integrity code). |
929 | |
f045efad |
930 | Some day you might get confronted by datasets that have ambiguous |
931 | positioning data (i.e. duplicate position values within the same group, |
b250066f |
932 | in a table without unique constraints). When manually fixing such data |
933 | keep in mind that you can not invoke L<DBIx::Class::Row/update> like |
f045efad |
934 | you normally would, as it will get confused by the wrong data before |
b250066f |
935 | having a chance to update the ill-defined row. If you really know what |
f045efad |
936 | you are doing use this method which bypasses any hooks introduced by |
b250066f |
937 | this module. |
938 | |
939 | =cut |
940 | |
bd7ca9e8 |
941 | sub _ordered_internal_update { |
942 | my $self = shift; |
943 | local $self->{_ORDERED_INTERNAL_UPDATE} = 1; |
944 | return $self->update (@_); |
945 | } |
fa6b598f |
946 | |
7a76f44c |
947 | 1; |
118e6b96 |
948 | |
bd7ca9e8 |
949 | __END__ |
dc66dea1 |
950 | |
bd7ca9e8 |
951 | =head1 CAVEATS |
dc66dea1 |
952 | |
133dd22a |
953 | =head2 Race Condition on Insert |
954 | |
118e6b96 |
955 | If a position is not specified for an insert than a position |
bd7ca9e8 |
956 | will be chosen based either on L</_initial_position_value> or |
957 | L</_next_position_value>, depending if there are already some |
958 | items in the current group. The space of time between the |
959 | necessary selects and insert introduces a race condition. |
960 | Having unique constraints on your position/group columns, |
961 | and using transactions (see L<DBIx::Class::Storage/txn_do>) |
962 | will prevent such race conditions going undetected. |
118e6b96 |
963 | |
133dd22a |
964 | =head2 Multiple Moves |
965 | |
966 | Be careful when issueing move_* methods to multiple objects. If |
967 | you've pre-loaded the objects then when you move one of the objects |
968 | the position of the other object will not reflect their new value |
bd7ca9e8 |
969 | until you reload them from the database - see |
970 | L<DBIx::Class::Row/discard_changes>. |
133dd22a |
971 | |
dc66dea1 |
972 | There are times when you will want to move objects as groups, such |
133dd22a |
973 | as changeing the parent of several objects at once - this directly |
974 | conflicts with this problem. One solution is for us to write a |
975 | ResultSet class that supports a parent() method, for example. Another |
976 | solution is to somehow automagically modify the objects that exist |
977 | in the current object's result set to have the new position value. |
978 | |
58755bba |
979 | =head2 Default Values |
980 | |
981 | Using a database defined default_value on one of your group columns |
982 | could result in the position not being assigned correctly. |
983 | |
118e6b96 |
984 | =head1 AUTHOR |
985 | |
8f535707 |
986 | Original code framework |
987 | Aran Deltac <bluefeet@cpan.org> |
988 | |
989 | Constraints support and code generalisation |
990 | Peter Rabbitson <ribasushi@cpan.org> |
118e6b96 |
991 | |
992 | =head1 LICENSE |
993 | |
994 | You may distribute this code under the same terms as Perl itself. |
995 | |