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