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 |
48580715 |
130 | that any unique constraints can not be violated. This value defaults |
bd7ca9e8 |
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 | |
c59dfc82 |
437 | # if we're given a single value, turn it into a hashref |
fa6b598f |
438 | unless (ref $to_group eq 'HASH') { |
bd7ca9e8 |
439 | my @gcols = $self->_grouping_columns; |
440 | |
441 | $self->throw_exception ('Single group supplied for a multi-column group identifier') if @gcols > 1; |
442 | $to_group = {$gcols[0] => $to_group}; |
fa6b598f |
443 | } |
444 | |
79dc353a |
445 | my $position_column = $self->position_column; |
79dc353a |
446 | |
79dc353a |
447 | return 0 if ( defined($to_position) and $to_position < 1 ); |
87b4a877 |
448 | |
449 | # check if someone changed the _grouping_columns - this will |
450 | # prevent _is_in_group working, so we need to requery the db |
451 | # for the original values |
452 | my (@dirty_cols, %values, $guard); |
453 | for ($self->_grouping_columns) { |
454 | $values{$_} = $self->get_column ($_); |
455 | push @dirty_cols, $_ if $self->is_column_changed ($_); |
79dc353a |
456 | } |
457 | |
87b4a877 |
458 | # re-query only the dirty columns, and restore them on the |
459 | # object (subsequent code will update them to the correct |
460 | # after-move values) |
461 | if (@dirty_cols) { |
462 | $guard = $self->result_source->schema->txn_scope_guard; |
8f535707 |
463 | |
87b4a877 |
464 | my $cursor = $self->result_source->resultset->search( |
465 | $self->ident_condition, |
466 | { select => \@dirty_cols }, |
467 | )->cursor; |
bd7ca9e8 |
468 | |
87b4a877 |
469 | my @original_values = $cursor->next; |
470 | $self->set_inflated_columns ({ %values, map { $_ => shift @original_values } (@dirty_cols) }); |
a98b5b2f |
471 | delete $self->{_dirty_columns}{$_} for (@dirty_cols); |
87b4a877 |
472 | } |
bd7ca9e8 |
473 | |
87b4a877 |
474 | if ($self->_is_in_group ($to_group) ) { |
475 | my $ret; |
476 | if (defined $to_position) { |
477 | $ret = $self->move_to ($to_position); |
478 | } |
bd7ca9e8 |
479 | |
87b4a877 |
480 | $guard->commit if $guard; |
481 | return $ret||0; |
482 | } |
bd7ca9e8 |
483 | |
87b4a877 |
484 | $guard ||= $self->result_source->schema->txn_scope_guard; |
485 | |
486 | # Move to end of current group to adjust siblings |
487 | $self->move_last; |
488 | |
489 | $self->set_inflated_columns({ %$to_group, $position_column => undef }); |
490 | my $new_group_last_posval = $self->_last_sibling_posval; |
491 | my $new_group_last_position = $self->_position_from_value ( |
492 | $new_group_last_posval |
493 | ); |
8f535707 |
494 | |
87b4a877 |
495 | if ( not defined($to_position) or $to_position > $new_group_last_position) { |
496 | $self->set_column( |
497 | $position_column => $new_group_last_position |
498 | ? $self->_next_position_value ( $new_group_last_posval ) |
499 | : $self->_initial_position_value |
500 | ); |
bd7ca9e8 |
501 | } |
87b4a877 |
502 | else { |
503 | my $bumped_pos_val = $self->_position_value ($to_position); |
71ec1155 |
504 | my @between = map { $self->_position_value ($_) } ($to_position, $new_group_last_position); |
87b4a877 |
505 | $self->_shift_siblings (1, @between); #shift right |
506 | $self->set_column( $position_column => $bumped_pos_val ); |
507 | } |
508 | |
509 | $self->_ordered_internal_update; |
510 | |
511 | $guard->commit; |
512 | |
513 | return 1; |
79dc353a |
514 | } |
515 | |
118e6b96 |
516 | =head2 insert |
517 | |
518 | Overrides the DBIC insert() method by providing a default |
519 | position number. The default will be the number of rows in |
520 | the table +1, thus positioning the new record at the last position. |
521 | |
522 | =cut |
523 | |
524 | sub insert { |
525 | my $self = shift; |
526 | my $position_column = $self->position_column; |
bd7ca9e8 |
527 | |
528 | unless ($self->get_column($position_column)) { |
d7c0e320 |
529 | my $lsib_posval = $self->_last_sibling_posval; |
bd7ca9e8 |
530 | $self->set_column( |
d7c0e320 |
531 | $position_column => (defined $lsib_posval |
532 | ? $self->_next_position_value ( $lsib_posval ) |
bd7ca9e8 |
533 | : $self->_initial_position_value |
534 | ) |
535 | ); |
536 | } |
537 | |
0a298c73 |
538 | return $self->next::method( @_ ); |
118e6b96 |
539 | } |
540 | |
79dc353a |
541 | =head2 update |
542 | |
543 | Overrides the DBIC update() method by checking for a change |
544 | to the position and/or group columns. Movement within a |
545 | group or to another group is handled by repositioning |
546 | the appropriate siblings. Position defaults to the end |
547 | of a new group if it has been changed to undef. |
548 | |
549 | =cut |
550 | |
551 | sub update { |
552 | my $self = shift; |
553 | |
bd7ca9e8 |
554 | # this is set by _ordered_internal_update() |
555 | return $self->next::method(@_) if $self->{_ORDERED_INTERNAL_UPDATE}; |
79dc353a |
556 | |
bd7ca9e8 |
557 | my $position_column = $self->position_column; |
87b4a877 |
558 | my @ordering_columns = ($self->_grouping_columns, $position_column); |
559 | |
560 | |
561 | # these steps are necessary to keep the external appearance of |
562 | # ->update($upd) so that other things overloading update() will |
563 | # work properly |
2adb95f6 |
564 | my %original_values = $self->get_columns; |
87b4a877 |
565 | my %existing_changes = $self->get_dirty_columns; |
566 | |
567 | # See if any of the *supplied* changes would affect the ordering |
568 | # The reason this is so contrived, is that we want to leverage |
569 | # the datatype aware value comparing, while at the same time |
570 | # keep the original value intact (it will be updated later by the |
571 | # corresponding routine) |
572 | |
573 | my %upd = %{shift || {}}; |
574 | my %changes = %existing_changes; |
575 | |
576 | for (@ordering_columns) { |
577 | next unless exists $upd{$_}; |
578 | |
579 | # we do not want to keep propagating this to next::method |
580 | # as it will be a done deal by the time get there |
581 | my $value = delete $upd{$_}; |
582 | $self->set_inflated_columns ({ $_ => $value }); |
583 | |
584 | # see if an update resulted in a dirty column |
585 | # it is important to preserve the old value, as it |
586 | # will be needed to carry on a successfull move() |
587 | # operation without re-querying the database |
588 | if ($self->is_column_changed ($_) && not exists $existing_changes{$_}) { |
589 | $changes{$_} = $value; |
590 | $self->set_inflated_columns ({ $_ => $original_values{$_} }); |
591 | delete $self->{_dirty_columns}{$_}; |
592 | } |
593 | } |
fa6b598f |
594 | |
bd7ca9e8 |
595 | # if nothing group/position related changed - short circuit |
87b4a877 |
596 | if (not grep { exists $changes{$_} } ( @ordering_columns ) ) { |
597 | return $self->next::method( \%upd, @_ ); |
bd7ca9e8 |
598 | } |
fa6b598f |
599 | |
bd7ca9e8 |
600 | { |
8f535707 |
601 | my $guard = $self->result_source->schema->txn_scope_guard; |
602 | |
bd7ca9e8 |
603 | # if any of our grouping columns have been changed |
604 | if (grep { exists $changes{$_} } ($self->_grouping_columns) ) { |
605 | |
606 | # create new_group by taking the current group and inserting changes |
607 | my $new_group = {$self->_grouping_clause}; |
608 | foreach my $col (keys %$new_group) { |
87b4a877 |
609 | $new_group->{$col} = $changes{$col} if exists $changes{$col}; |
fa6b598f |
610 | } |
bd7ca9e8 |
611 | |
612 | $self->move_to_group( |
613 | $new_group, |
614 | (exists $changes{$position_column} |
87b4a877 |
615 | # The FIXME bit contradicts the documentation: POD states that |
616 | # when changing groups without supplying explicit positions in |
617 | # move_to_group(), we push the item to the end of the group. |
618 | # However when I was rewriting this, the position from the old |
619 | # group was clearly passed to the new one |
bd7ca9e8 |
620 | # Probably needs to go away (by ribasushi) |
87b4a877 |
621 | ? $changes{$position_column} # means there was a position change supplied with the update too |
622 | : $self->_position # FIXME! (replace with undef) |
bd7ca9e8 |
623 | ), |
624 | ); |
625 | } |
626 | elsif (exists $changes{$position_column}) { |
87b4a877 |
627 | $self->move_to($changes{$position_column}); |
fa6b598f |
628 | } |
629 | |
8f535707 |
630 | my @res; |
631 | my $want = wantarray(); |
632 | if (not defined $want) { |
87b4a877 |
633 | $self->next::method( \%upd, @_ ); |
8f535707 |
634 | } |
635 | elsif ($want) { |
87b4a877 |
636 | @res = $self->next::method( \%upd, @_ ); |
8f535707 |
637 | } |
638 | else { |
87b4a877 |
639 | $res[0] = $self->next::method( \%upd, @_ ); |
8f535707 |
640 | } |
641 | |
642 | $guard->commit; |
643 | return $want ? @res : $res[0]; |
79dc353a |
644 | } |
79dc353a |
645 | } |
646 | |
118e6b96 |
647 | =head2 delete |
648 | |
649 | Overrides the DBIC delete() method by first moving the object |
bd7ca9e8 |
650 | to the last position, then deleting it, thus ensuring the |
118e6b96 |
651 | integrity of the positions. |
652 | |
653 | =cut |
654 | |
655 | sub delete { |
656 | my $self = shift; |
8f535707 |
657 | |
658 | my $guard = $self->result_source->schema->txn_scope_guard; |
659 | |
660 | $self->move_last; |
661 | |
662 | my @res; |
663 | my $want = wantarray(); |
664 | if (not defined $want) { |
665 | $self->next::method( @_ ); |
bd7ca9e8 |
666 | } |
8f535707 |
667 | elsif ($want) { |
668 | @res = $self->next::method( @_ ); |
669 | } |
670 | else { |
671 | $res[0] = $self->next::method( @_ ); |
672 | } |
673 | |
674 | $guard->commit; |
675 | return $want ? @res : $res[0]; |
bd7ca9e8 |
676 | } |
677 | |
b250066f |
678 | =head1 METHODS FOR EXTENDING ORDERED |
bd7ca9e8 |
679 | |
680 | You would want to override the methods below if you use sparse |
681 | (non-linear) or non-numeric position values. This can be useful |
682 | if you are working with preexisting non-normalised position data, |
683 | or if you need to work with materialized path columns. |
684 | |
d7c0e320 |
685 | =head2 _position_from_value |
686 | |
69cd8a7f |
687 | my $num_pos = $item->_position_from_value ( $pos_value ) |
d7c0e320 |
688 | |
689 | Returns the B<absolute numeric position> of an object with a B<position |
690 | value> set to C<$pos_value>. By default simply returns C<$pos_value>. |
691 | |
692 | =cut |
693 | sub _position_from_value { |
694 | my ($self, $val) = @_; |
695 | |
696 | return 0 unless defined $val; |
697 | |
698 | # #the right way to do this |
699 | # return $self -> _group_rs |
700 | # -> search({ $self->position_column => { '<=', $val } }) |
701 | # -> count |
702 | |
703 | return $val; |
704 | } |
705 | |
bd7ca9e8 |
706 | =head2 _position_value |
707 | |
708 | my $pos_value = $item->_position_value ( $pos ) |
709 | |
b250066f |
710 | Returns the B<value> of L</position_column> of the object at numeric |
bd7ca9e8 |
711 | position C<$pos>. By default simply returns C<$pos>. |
712 | |
713 | =cut |
714 | sub _position_value { |
715 | my ($self, $pos) = @_; |
716 | |
717 | # #the right way to do this (not optimized) |
718 | # my $position_column = $self->position_column; |
719 | # return $self -> _group_rs |
720 | # -> search({}, { order_by => $position_column }) |
721 | # -> slice ( $pos - 1) |
722 | # -> single |
723 | # -> get_column ($position_column); |
724 | |
725 | return $pos; |
726 | } |
727 | |
728 | =head2 _initial_position_value |
729 | |
730 | __PACKAGE__->_initial_position_value(0); |
731 | |
b250066f |
732 | This method specifies a B<value> of L</position_column> which is assigned |
bd7ca9e8 |
733 | to the first inserted element of a group, if no value was supplied at |
734 | insertion time. All subsequent values are derived from this one by |
735 | L</_next_position_value> below. Defaults to 1. |
736 | |
737 | =cut |
738 | |
739 | __PACKAGE__->mk_classdata( '_initial_position_value' => 1 ); |
740 | |
741 | =head2 _next_position_value |
742 | |
743 | my $new_value = $item->_next_position_value ( $position_value ) |
744 | |
b250066f |
745 | Returns a position B<value> that would be considered C<next> with |
bd7ca9e8 |
746 | regards to C<$position_value>. Can be pretty much anything, given |
747 | that C<< $position_value < $new_value >> where C<< < >> is the |
748 | SQL comparison operator (usually works fine on strings). The |
749 | default method expects C<$position_value> to be numeric, and |
750 | returns C<$position_value + 1> |
751 | |
752 | =cut |
753 | sub _next_position_value { |
754 | return $_[1] + 1; |
755 | } |
756 | |
757 | =head2 _shift_siblings |
758 | |
759 | $item->_shift_siblings ($direction, @between) |
760 | |
b250066f |
761 | Shifts all siblings with B<positions values> in the range @between |
762 | (inclusive) by one position as specified by $direction (left if < 0, |
763 | right if > 0). By default simply increments/decrements each |
764 | L<position_column> value by 1, doing so in a way as to not violate |
765 | any existing constraints. |
766 | |
767 | Note that if you override this method and have unique constraints |
768 | including the L<position_column> the shift is not a trivial task. |
769 | Refer to the implementation source of the default method for more |
770 | information. |
bd7ca9e8 |
771 | |
772 | =cut |
773 | sub _shift_siblings { |
774 | my ($self, $direction, @between) = @_; |
775 | return 0 unless $direction; |
776 | |
777 | my $position_column = $self->position_column; |
778 | |
779 | my ($op, $ord); |
780 | if ($direction < 0) { |
781 | $op = '-'; |
782 | $ord = 'asc'; |
783 | } |
784 | else { |
785 | $op = '+'; |
786 | $ord = 'desc'; |
787 | } |
788 | |
789 | my $shift_rs = $self->_group_rs-> search ({ $position_column => { -between => \@between } }); |
790 | |
791 | # some databases (sqlite) are dumb and can not do a blanket |
792 | # increment/decrement. So what we do here is check if the |
793 | # position column is part of a unique constraint, and do a |
794 | # one-by-one update if this is the case |
795 | |
82a8f76f |
796 | my $rsrc = $self->result_source; |
797 | |
798 | if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $rsrc->unique_constraints }} ) ) ) { |
799 | |
e8fb771b |
800 | my @pcols = $rsrc->_pri_cols; |
82a8f76f |
801 | my $cursor = $shift_rs->search ({}, { order_by => { "-$ord", $position_column }, columns => \@pcols } )->cursor; |
802 | my $rs = $self->result_source->resultset; |
803 | |
a83cdbf2 |
804 | my @all_pks = $cursor->all; |
e8fb771b |
805 | while (my $pks = shift @all_pks) { |
82a8f76f |
806 | my $cond; |
807 | for my $i (0.. $#pcols) { |
e8fb771b |
808 | $cond->{$pcols[$i]} = $pks->[$i]; |
82a8f76f |
809 | } |
bd7ca9e8 |
810 | |
82a8f76f |
811 | $rs->search($cond)->update ({ $position_column => \ "$position_column $op 1" } ); |
bd7ca9e8 |
812 | } |
813 | } |
814 | else { |
815 | $shift_rs->update ({ $position_column => \ "$position_column $op 1" } ); |
816 | } |
118e6b96 |
817 | } |
818 | |
7a76f44c |
819 | =head1 PRIVATE METHODS |
820 | |
821 | These methods are used internally. You should never have the |
822 | need to use them. |
823 | |
bd7ca9e8 |
824 | =head2 _group_rs |
825 | |
b250066f |
826 | This method returns a resultset containing all members of the row |
bd7ca9e8 |
827 | group (including the row itself). |
828 | |
829 | =cut |
830 | sub _group_rs { |
831 | my $self = shift; |
832 | return $self->result_source->resultset->search({$self->_grouping_clause()}); |
833 | } |
834 | |
835 | =head2 _siblings |
836 | |
837 | Returns an unordered resultset of all objects in the same group |
838 | excluding the object you called this method on. |
839 | |
840 | =cut |
841 | sub _siblings { |
842 | my $self = shift; |
843 | my $position_column = $self->position_column; |
844 | return $self->_group_rs->search( |
845 | { $position_column => { '!=' => $self->get_column($position_column) } }, |
846 | ); |
847 | } |
848 | |
69cd8a7f |
849 | =head2 _position |
850 | |
851 | my $num_pos = $item->_position; |
852 | |
853 | Returns the B<absolute numeric position> of the current object, with the |
854 | first object being at position 1, its sibling at position 2 and so on. |
855 | |
856 | =cut |
857 | sub _position { |
858 | my $self = shift; |
859 | return $self->_position_from_value ($self->get_column ($self->position_column) ); |
860 | } |
861 | |
a733c37f |
862 | =head2 _grouping_clause |
118e6b96 |
863 | |
bd7ca9e8 |
864 | This method returns one or more name=>value pairs for limiting a search |
87b4a877 |
865 | by the grouping column(s). If the grouping column is not defined then |
866 | this will return an empty list. |
118e6b96 |
867 | |
7a76f44c |
868 | =cut |
a733c37f |
869 | sub _grouping_clause { |
169bb185 |
870 | my( $self ) = @_; |
fa6b598f |
871 | return map { $_ => $self->get_column($_) } $self->_grouping_columns(); |
872 | } |
873 | |
fa6b598f |
874 | =head2 _get_grouping_columns |
875 | |
876 | Returns a list of the column names used for grouping, regardless of whether |
1d941d67 |
877 | they were specified as an arrayref or a single string, and returns () |
878 | if there is no grouping. |
fa6b598f |
879 | |
880 | =cut |
881 | sub _grouping_columns { |
882 | my( $self ) = @_; |
a733c37f |
883 | my $col = $self->grouping_column(); |
fa6b598f |
884 | if (ref $col eq 'ARRAY') { |
885 | return @$col; |
886 | } elsif ($col) { |
887 | return ( $col ); |
888 | } else { |
889 | return (); |
133dd22a |
890 | } |
7a76f44c |
891 | } |
892 | |
bd7ca9e8 |
893 | =head2 _is_in_group |
fa6b598f |
894 | |
895 | $item->_is_in_group( {user => 'fred', list => 'work'} ) |
896 | |
897 | Returns true if the object is in the group represented by hashref $other |
bd7ca9e8 |
898 | |
fa6b598f |
899 | =cut |
900 | sub _is_in_group { |
901 | my ($self, $other) = @_; |
902 | my $current = {$self->_grouping_clause}; |
bd7ca9e8 |
903 | |
904 | no warnings qw/uninitialized/; |
905 | |
906 | return 0 if ( |
907 | join ("\x00", sort keys %$current) |
908 | ne |
909 | join ("\x00", sort keys %$other) |
910 | ); |
fa6b598f |
911 | for my $key (keys %$current) { |
fa6b598f |
912 | return 0 if $current->{$key} ne $other->{$key}; |
913 | } |
914 | return 1; |
915 | } |
916 | |
b250066f |
917 | =head2 _ordered_internal_update |
918 | |
919 | This is a short-circuited method, that is used internally by this |
920 | module to update positioning values in isolation (i.e. without |
921 | triggering any of the positioning integrity code). |
922 | |
f045efad |
923 | Some day you might get confronted by datasets that have ambiguous |
48580715 |
924 | positioning data (e.g. duplicate position values within the same group, |
b250066f |
925 | in a table without unique constraints). When manually fixing such data |
926 | keep in mind that you can not invoke L<DBIx::Class::Row/update> like |
f045efad |
927 | you normally would, as it will get confused by the wrong data before |
b250066f |
928 | having a chance to update the ill-defined row. If you really know what |
f045efad |
929 | you are doing use this method which bypasses any hooks introduced by |
b250066f |
930 | this module. |
931 | |
932 | =cut |
933 | |
bd7ca9e8 |
934 | sub _ordered_internal_update { |
935 | my $self = shift; |
936 | local $self->{_ORDERED_INTERNAL_UPDATE} = 1; |
937 | return $self->update (@_); |
938 | } |
fa6b598f |
939 | |
7a76f44c |
940 | 1; |
118e6b96 |
941 | |
bd7ca9e8 |
942 | __END__ |
dc66dea1 |
943 | |
bd7ca9e8 |
944 | =head1 CAVEATS |
dc66dea1 |
945 | |
65285cf7 |
946 | =head2 Resultset Methods |
947 | |
948 | Note that all Insert/Create/Delete overrides are happening on |
949 | L<DBIx::Class::Row> methods only. If you use the |
950 | L<DBIx::Class::ResultSet> versions of |
951 | L<update|DBIx::Class::ResultSet/update> or |
952 | L<delete|DBIx::Class::ResultSet/delete>, all logic present in this |
953 | module will be bypassed entirely (possibly resulting in a broken |
954 | order-tree). Instead always use the |
955 | L<update_all|DBIx::Class::ResultSet/update_all> and |
956 | L<delete_all|DBIx::Class::ResultSet/delete_all> methods, which will |
957 | invoke the corresponding L<row|DBIx::Class::Row> method on every |
958 | member of the given resultset. |
959 | |
133dd22a |
960 | =head2 Race Condition on Insert |
961 | |
65285cf7 |
962 | If a position is not specified for an insert, a position |
bd7ca9e8 |
963 | will be chosen based either on L</_initial_position_value> or |
964 | L</_next_position_value>, depending if there are already some |
965 | items in the current group. The space of time between the |
966 | necessary selects and insert introduces a race condition. |
967 | Having unique constraints on your position/group columns, |
968 | and using transactions (see L<DBIx::Class::Storage/txn_do>) |
969 | will prevent such race conditions going undetected. |
118e6b96 |
970 | |
133dd22a |
971 | =head2 Multiple Moves |
972 | |
48580715 |
973 | Be careful when issuing move_* methods to multiple objects. If |
133dd22a |
974 | you've pre-loaded the objects then when you move one of the objects |
975 | the position of the other object will not reflect their new value |
bd7ca9e8 |
976 | until you reload them from the database - see |
977 | L<DBIx::Class::Row/discard_changes>. |
133dd22a |
978 | |
dc66dea1 |
979 | There are times when you will want to move objects as groups, such |
48580715 |
980 | as changing the parent of several objects at once - this directly |
133dd22a |
981 | conflicts with this problem. One solution is for us to write a |
982 | ResultSet class that supports a parent() method, for example. Another |
983 | solution is to somehow automagically modify the objects that exist |
984 | in the current object's result set to have the new position value. |
985 | |
58755bba |
986 | =head2 Default Values |
987 | |
988 | Using a database defined default_value on one of your group columns |
989 | could result in the position not being assigned correctly. |
990 | |
118e6b96 |
991 | =head1 AUTHOR |
992 | |
8f535707 |
993 | Original code framework |
994 | Aran Deltac <bluefeet@cpan.org> |
995 | |
996 | Constraints support and code generalisation |
997 | Peter Rabbitson <ribasushi@cpan.org> |
118e6b96 |
998 | |
999 | =head1 LICENSE |
1000 | |
1001 | You may distribute this code under the same terms as Perl itself. |
1002 | |