Typo in scalar ref example
[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   # Optional: group_id INTEGER NOT NULL
21
22 In your Schema or DB class add Ordered to the top 
23 of the component list.
24
25   __PACKAGE__->load_components(qw( Ordered ... ));
26
27 Specify the column that stores the position number for 
28 each row.
29
30   package My::Item;
31   __PACKAGE__->position_column('position');
32   __PACKAGE__->grouping_column('group_id'); # optional
33
34 Thats it, now you can change the position of your objects.
35
36   #!/use/bin/perl
37   use My::Item;
38   
39   my $item = My::Item->create({ name=>'Matt S. Trout' });
40   # If using grouping_column:
41   my $item = My::Item->create({ name=>'Matt S. Trout', group_id=>1 });
42   
43   my $rs = $item->siblings();
44   my @siblings = $item->siblings();
45   
46   my $sibling;
47   $sibling = $item->first_sibling();
48   $sibling = $item->last_sibling();
49   $sibling = $item->previous_sibling();
50   $sibling = $item->next_sibling();
51   
52   $item->move_previous();
53   $item->move_next();
54   $item->move_first();
55   $item->move_last();
56   $item->move_to( $position );
57
58 =head1 DESCRIPTION
59
60 This module provides a simple interface for modifying the ordered 
61 position of DBIx::Class objects.
62
63 =head1 AUTO UPDATE
64
65 All of the move_* methods automatically update the rows involved in 
66 the query.  This is not configurable and is due to the fact that if you 
67 move a record it always causes other records in the list to be updated.
68
69 =head1 METHODS
70
71 =head2 position_column
72
73   __PACKAGE__->position_column('position');
74
75 Sets and retrieves the name of the column that stores the 
76 positional value of each record.  Default to "position".
77
78 =cut
79
80 __PACKAGE__->mk_classdata( 'position_column' => 'position' );
81
82 =head2 grouping_column
83
84   __PACKAGE__->grouping_column('group_id');
85
86 This method specified a column to limit all queries in 
87 this module by.  This effectively allows you to have multiple 
88 ordered lists within the same table.
89
90 =cut
91
92 __PACKAGE__->mk_classdata( 'grouping_column' );
93
94 =head2 siblings
95
96   my $rs = $item->siblings();
97   my @siblings = $item->siblings();
98
99 Returns either a result set or an array of all other objects 
100 excluding the one you called it on.
101
102 =cut
103
104 sub siblings {
105     my( $self ) = @_;
106     my $position_column = $self->position_column;
107     my $rs = $self->result_source->resultset->search(
108         {
109             $position_column => { '!=' => $self->get_column($position_column) },
110             $self->_grouping_clause(),
111         },
112         { order_by => $self->position_column },
113     );
114     return $rs->all() if (wantarray());
115     return $rs;
116 }
117
118 =head2 first_sibling
119
120   my $sibling = $item->first_sibling();
121
122 Returns the first sibling object, or 0 if the first sibling 
123 is this sibliing.
124
125 =cut
126
127 sub first_sibling {
128     my( $self ) = @_;
129     return 0 if ($self->get_column($self->position_column())==1);
130     return ($self->result_source->resultset->search(
131         {
132             $self->position_column => 1,
133             $self->_grouping_clause(),
134         },
135     )->all())[0];
136 }
137
138 =head2 last_sibling
139
140   my $sibling = $item->last_sibling();
141
142 Return the last sibling, or 0 if the last sibling is this 
143 sibling.
144
145 =cut
146
147 sub last_sibling {
148     my( $self ) = @_;
149     my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
150     return 0 if ($self->get_column($self->position_column())==$count);
151     return ($self->result_source->resultset->search(
152         {
153             $self->position_column => $count,
154             $self->_grouping_clause(),
155         },
156     )->all())[0];
157 }
158
159 =head2 previous_sibling
160
161   my $sibling = $item->previous_sibling();
162
163 Returns the sibling that resides one position back.  Undef 
164 is returned if the current object is the first one.
165
166 =cut
167
168 sub previous_sibling {
169     my( $self ) = @_;
170     my $position_column = $self->position_column;
171     my $position = $self->get_column( $position_column );
172     return 0 if ($position==1);
173     return ($self->result_source->resultset->search(
174         {
175             $position_column => $position - 1,
176             $self->_grouping_clause(),
177         }
178     )->all())[0];
179 }
180
181 =head2 next_sibling
182
183   my $sibling = $item->next_sibling();
184
185 Returns the sibling that resides one position foward.  Undef 
186 is returned if the current object is the last one.
187
188 =cut
189
190 sub next_sibling {
191     my( $self ) = @_;
192     my $position_column = $self->position_column;
193     my $position = $self->get_column( $position_column );
194     my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
195     return 0 if ($position==$count);
196     return ($self->result_source->resultset->search(
197         {
198             $position_column => $position + 1,
199             $self->_grouping_clause(),
200         },
201     )->all())[0];
202 }
203
204 =head2 move_previous
205
206   $item->move_previous();
207
208 Swaps position with the sibling on position previous in the list.  
209 1 is returned on success, and 0 is returned if the objects is already 
210 the first one.
211
212 =cut
213
214 sub move_previous {
215     my( $self ) = @_;
216     my $position = $self->get_column( $self->position_column() );
217     return $self->move_to( $position - 1 );
218 }
219
220 =head2 move_next
221
222   $item->move_next();
223
224 Swaps position with the sibling in the next position.  1 is returned on 
225 success, and 0 is returned if the object is already the last in the list.
226
227 =cut
228
229 sub move_next {
230     my( $self ) = @_;
231     my $position = $self->get_column( $self->position_column() );
232     my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
233     return 0 if ($position==$count);
234     return $self->move_to( $position + 1 );
235 }
236
237 =head2 move_first
238
239   $item->move_first();
240
241 Moves the object to the first position.  1 is returned on 
242 success, and 0 is returned if the object is already the first.
243
244 =cut
245
246 sub move_first {
247     my( $self ) = @_;
248     return $self->move_to( 1 );
249 }
250
251 =head2 move_last
252
253   $item->move_last();
254
255 Moves the object to the very last position.  1 is returned on 
256 success, and 0 is returned if the object is already the last one.
257
258 =cut
259
260 sub move_last {
261     my( $self ) = @_;
262     my $count = $self->result_source->resultset->search({$self->_grouping_clause()})->count();
263     return $self->move_to( $count );
264 }
265
266 =head2 move_to
267
268   $item->move_to( $position );
269
270 Moves the object to the specified position.  1 is returned on 
271 success, and 0 is returned if the object is already at the 
272 specified position.
273
274 =cut
275
276 sub move_to {
277     my( $self, $to_position ) = @_;
278     my $position_column = $self->position_column;
279     my $from_position = $self->get_column( $position_column );
280     return 0 if ( $to_position < 1 );
281     return 0 if ( $from_position==$to_position );
282     my @between = (
283         ( $from_position < $to_position )
284         ? ( $from_position+1, $to_position )
285         : ( $to_position, $from_position-1 )
286     );
287     my $rs = $self->result_source->resultset->search({
288         $position_column => { -between => [ @between ] },
289         $self->_grouping_clause(),
290     });
291     my $op = ($from_position>$to_position) ? '+' : '-';
292     $rs->update({ $position_column => \"$position_column $op 1" });
293     $self->update({ $position_column => $to_position });
294     return 1;
295 }
296
297 =head2 insert
298
299 Overrides the DBIC insert() method by providing a default 
300 position number.  The default will be the number of rows in 
301 the table +1, thus positioning the new record at the last position.
302
303 =cut
304
305 sub insert {
306     my $self = shift;
307     my $position_column = $self->position_column;
308     $self->set_column( $position_column => $self->result_source->resultset->search( {$self->_grouping_clause()} )->count()+1 ) 
309         if (!$self->get_column($position_column));
310     return $self->next::method( @_ );
311 }
312
313 =head2 delete
314
315 Overrides the DBIC delete() method by first moving the object 
316 to the last position, then deleting it, thus ensuring the 
317 integrity of the positions.
318
319 =cut
320
321 sub delete {
322     my $self = shift;
323     $self->move_last;
324     return $self->next::method( @_ );
325 }
326
327 =head1 PRIVATE METHODS
328
329 These methods are used internally.  You should never have the 
330 need to use them.
331
332 =head2 _grouping_clause
333
334 This method returns a name=>value pare for limiting a search 
335 by the collection column.  If the collection column is not 
336 defined then this will return an empty list.
337
338 =cut
339
340 sub _grouping_clause {
341     my( $self ) = @_;
342     my $col = $self->grouping_column();
343     if ($col) {
344         return ( $col => $self->get_column($col) );
345     }
346     return ();
347 }
348
349 1;
350 __END__
351
352 =head1 BUGS
353
354 =head2 Unique Constraints
355
356 Unique indexes and constraints on the position column are not 
357 supported at this time.  It would be make sense to support them, 
358 but there are some unexpected database issues that make this 
359 hard to do.  The main problem from the author's view is that 
360 SQLite (the DB engine that we use for testing) does not support 
361 ORDER BY on updates.
362
363 =head2 Race Condition on Insert
364
365 If a position is not specified for an insert than a position 
366 will be chosen based on COUNT(*)+1.  But, it first selects the 
367 count then inserts the record.  The space of time between select 
368 and insert introduces a race condition.  To fix this we need the 
369 ability to lock tables in DBIC.  I've added an entry in the TODO 
370 about this.
371
372 =head2 Multiple Moves
373
374 Be careful when issueing move_* methods to multiple objects.  If 
375 you've pre-loaded the objects then when you move one of the objects 
376 the position of the other object will not reflect their new value 
377 until you reload them from the database.
378
379 There are times when you will want to move objects as groups, such 
380 as changeing the parent of several objects at once - this directly 
381 conflicts with this problem.  One solution is for us to write a 
382 ResultSet class that supports a parent() method, for example.  Another 
383 solution is to somehow automagically modify the objects that exist 
384 in the current object's result set to have the new position value.
385
386 =head1 AUTHOR
387
388 Aran Deltac <bluefeet@cpan.org>
389
390 =head1 LICENSE
391
392 You may distribute this code under the same terms as Perl itself.
393