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