Using "is" instead of "cmp_ok"
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / Ordered.pm
1 package DBIx::Class::Ordered;
2 use strict;
3 use warnings;
4 use base qw( DBIx::Class );
5
6 =head1 NAME
7
8 DBIx::Class::Ordered - Modify the position of objects in an ordered list.
9
10 =head1 SYNOPSIS
11
12 Create a table for your ordered data.
13
14   CREATE TABLE items (
15     item_id INTEGER PRIMARY KEY AUTOINCREMENT,
16     name TEXT NOT NULL,
17     position INTEGER NOT NULL
18   );
19
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
40 In your Schema or DB class add "Ordered" to the top 
41 of the component list.
42
43   __PACKAGE__->load_components(qw( Ordered ... ));
44
45 Specify the column that stores the position number for 
46 each row.
47
48   package My::Item;
49   __PACKAGE__->position_column('position');
50
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
59 That's it, now you can change the position of your objects.
60
61   #!/use/bin/perl
62   use My::Item;
63   
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 });
67   
68   my $rs = $item->siblings();
69   my @siblings = $item->siblings();
70   
71   my $sibling;
72   $sibling = $item->first_sibling();
73   $sibling = $item->last_sibling();
74   $sibling = $item->previous_sibling();
75   $sibling = $item->next_sibling();
76   
77   $item->move_previous();
78   $item->move_next();
79   $item->move_first();
80   $item->move_last();
81   $item->move_to( $position );
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 );
86
87 =head1 DESCRIPTION
88
89 This module provides a simple interface for modifying the ordered 
90 position of DBIx::Class objects.
91
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
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 
105 positional value of each record.  Defaults to "position".
106
107 =cut
108
109 __PACKAGE__->mk_classdata( 'position_column' => 'position' );
110
111 =head2 grouping_column
112
113   __PACKAGE__->grouping_column('group_id');
114
115 This method specifies a column to limit all queries in 
116 this module by.  This effectively allows you to have multiple 
117 ordered lists within the same table.
118
119 =cut
120
121 __PACKAGE__->mk_classdata( 'grouping_column' );
122
123 =head2 null_position_value
124
125   __PACKAGE__->null_position_value(undef);
126
127 This method specifies a value of L</position_column> which B<would
128 never be assigned to a row> during normal operation. When
129 a row is moved, its position is set to this value temporarily, so
130 that any unique constrainst can not be violated. This value defaults
131 to 0, which should work for all cases except when your positions do
132 indeed start from 0.
133
134 =cut
135
136 __PACKAGE__->mk_classdata( 'null_position_value' => 0 );
137
138 =head2 siblings
139
140   my $rs = $item->siblings();
141   my @siblings = $item->siblings();
142
143 Returns an B<ordered> resultset of all other objects in the same
144 group excluding the one you called it on.
145
146 The ordering is a backwards-compatibility artifact - if you need
147 a resultset with no ordering applied use L</_siblings>
148
149 =cut
150 sub siblings {
151     my $self = shift;
152     return $self->_siblings->search ({}, { order_by => $self->position_column } );
153 }
154
155 =head2 previous_siblings
156
157   my $prev_rs = $item->previous_siblings();
158   my @prev_siblings = $item->previous_siblings();
159
160 Returns a resultset of all objects in the same group
161 positioned before the object on which this method was called.
162
163 =cut
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     );
172 }
173
174 =head2 next_siblings
175
176   my $next_rs = $item->next_siblings();
177   my @next_siblings = $item->next_siblings();
178
179 Returns a resultset of all objects in the same group
180 positioned after the object on which this method was called.
181
182 =cut
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     );
191 }
192
193 =head2 previous_sibling
194
195   my $sibling = $item->previous_sibling();
196
197 Returns the sibling that resides one position back.  Returns 0
198 if the current object is the first one.
199
200 =cut
201
202 sub previous_sibling {
203     my $self = shift;
204     my $position_column = $self->position_column;
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;
233 }
234
235 =head2 next_sibling
236
237   my $sibling = $item->next_sibling();
238
239 Returns the sibling that resides one position forward. Returns 0
240 if the current object is the last one.
241
242 =cut
243
244 sub next_sibling {
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;
266     my $position_column = $self->position_column;
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;
273 }
274
275 =head2 move_previous
276
277   $item->move_previous();
278
279 Swaps position with the sibling in the position previous in
280 the list.  Returns 1 on success, and 0 if the object is
281 already the first one.
282
283 =cut
284
285 sub move_previous {
286     my $self = shift;
287     return $self->move_to ($self->_position - 1);
288 }
289
290 =head2 move_next
291
292   $item->move_next();
293
294 Swaps position with the sibling in the next position in the
295 list.  Returns 1 on success, and 0 if the object is already
296 the last in the list.
297
298 =cut
299
300 sub move_next {
301     my $self = shift;
302     return 0 unless $self->next_siblings->count;
303     return $self->move_to ($self->_position + 1);
304 }
305
306 =head2 move_first
307
308   $item->move_first();
309
310 Moves the object to the first position in the list.  Returns 1
311 on success, and 0 if the object is already the first.
312
313 =cut
314
315 sub move_first {
316     return shift->move_to( 1 );
317 }
318
319 =head2 move_last
320
321   $item->move_last();
322
323 Moves the object to the last position in the list.  Returns 1
324 on success, and 0 if the object is already the last one.
325
326 =cut
327
328 sub move_last {
329     my $self = shift;
330     return $self->move_to( $self->_group_rs->count );
331 }
332
333 =head2 move_to
334
335   $item->move_to( $position );
336
337 Moves the object to the specified position.  Returns 1 on
338 success, and 0 if the object is already at the specified
339 position.
340
341 =cut
342
343 sub move_to {
344     my( $self, $to_position ) = @_;
345     return 0 if ( $to_position < 1 );
346
347     my $from_position = $self->_position;
348     return 0 if ( $from_position == $to_position );
349
350     my $position_column = $self->position_column;
351
352     {
353         my $guard = $self->result_source->schema->txn_scope_guard;
354
355         my ($direction, @between);
356         if ( $from_position < $to_position ) {
357             $direction = -1;
358             @between = map { $self->_position_value ($_) } ( $from_position + 1, $to_position );
359         }
360         else {
361             $direction = 1;
362             @between = map { $self->_position_value ($_) } ( $to_position, $from_position - 1 );
363         }
364
365         my $new_pos_val = $self->_position_value ($to_position);                              # record this before the shift
366
367         # we need to null-position the moved row if the position column is part of a constraint
368         if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $self->result_source->unique_constraints }} ) ) ) {
369             $self->_ordered_internal_update({ $position_column => $self->null_position_value });
370         }
371
372         $self->_shift_siblings ($direction, @between);
373         $self->_ordered_internal_update({ $position_column => $new_pos_val });
374
375         $guard->commit;
376
377         return 1;
378     }
379 }
380
381 =head2 move_to_group
382
383   $item->move_to_group( $group, $position );
384
385 Moves the object to the specified position of the specified
386 group, or to the end of the group if $position is undef.
387 1 is returned on success, and 0 is returned if the object is
388 already at the specified position of the specified group.
389
390 $group may be specified as a single scalar if only one 
391 grouping column is in use, or as a hashref of column => value pairs
392 if multiple grouping columns are in use.
393
394 =cut
395
396 sub move_to_group {
397     my( $self, $to_group, $to_position ) = @_;
398
399     $self->throw_exception ('move_to_group() expects a group specification')
400         unless defined $to_group;
401
402     # if we're given a string, turn it into a hashref
403     unless (ref $to_group eq 'HASH') {
404         my @gcols = $self->_grouping_columns;
405
406         $self->throw_exception ('Single group supplied for a multi-column group identifier') if @gcols > 1;
407         $to_group = {$gcols[0] => $to_group};
408     }
409
410     my $position_column = $self->position_column;
411
412     return 0 if ( defined($to_position) and $to_position < 1 );
413     if ($self->_is_in_group ($to_group) ) {
414         return 0 if not defined $to_position;
415         return $self->move_to ($to_position);
416     }
417
418     {
419         my $guard = $self->result_source->schema->txn_scope_guard;
420
421         # Move to end of current group to adjust siblings
422         $self->move_last;
423
424         $self->set_inflated_columns({ %$to_group, $position_column => undef });
425         my $new_group_count = $self->_group_rs->count;
426
427         if ( not defined($to_position) or $to_position > $new_group_count) {
428             $self->set_column(
429                 $position_column => $new_group_count
430                     ? $self->_next_position_value ( $self->last_sibling->get_column ($position_column) )    # FIXME - no need to inflate last_sibling
431                     : $self->_initial_position_value
432             );
433         }
434         else {
435             my $bumped_pos_val = $self->_position_value ($to_position);
436             my @between = ($to_position, $new_group_count);
437             $self->_shift_siblings (1, @between);   #shift right
438             $self->set_column( $position_column => $bumped_pos_val );
439         }
440
441         $self->_ordered_internal_update;
442
443         $guard->commit;
444
445         return 1;
446     }
447 }
448
449 =head2 insert
450
451 Overrides the DBIC insert() method by providing a default 
452 position number.  The default will be the number of rows in 
453 the table +1, thus positioning the new record at the last position.
454
455 =cut
456
457 sub insert {
458     my $self = shift;
459     my $position_column = $self->position_column;
460
461     unless ($self->get_column($position_column)) {
462         my $lsib = $self->last_sibling;     # FIXME - no need to inflate last_sibling
463         $self->set_column(
464             $position_column => ($lsib
465                 ? $self->_next_position_value ( $lsib->get_column ($position_column) )
466                 : $self->_initial_position_value
467             )
468         );
469     }
470
471     return $self->next::method( @_ );
472 }
473
474 =head2 update
475
476 Overrides the DBIC update() method by checking for a change
477 to the position and/or group columns.  Movement within a
478 group or to another group is handled by repositioning
479 the appropriate siblings.  Position defaults to the end
480 of a new group if it has been changed to undef.
481
482 =cut
483
484 sub update {
485     my $self = shift;
486
487     # this is set by _ordered_internal_update()
488     return $self->next::method(@_) if $self->{_ORDERED_INTERNAL_UPDATE};
489
490     my $upd = shift;
491     $self->set_inflated_columns($upd) if $upd;
492     my %changes = $self->get_dirty_columns;
493     $self->discard_changes;
494
495     my $position_column = $self->position_column;
496
497     # if nothing group/position related changed - short circuit
498     if (not grep { exists $changes{$_} } ($self->_grouping_columns, $position_column) ) {
499         return $self->next::method( \%changes, @_ );
500     }
501
502     {
503         my $guard = $self->result_source->schema->txn_scope_guard;
504
505         # if any of our grouping columns have been changed
506         if (grep { exists $changes{$_} } ($self->_grouping_columns) ) {
507
508             # create new_group by taking the current group and inserting changes
509             my $new_group = {$self->_grouping_clause};
510             foreach my $col (keys %$new_group) {
511                 if (exists $changes{$col}) {
512                     $new_group->{$col} = delete $changes{$col}; # don't want to pass this on to next::method
513                 }
514             }
515
516             $self->move_to_group(
517                 $new_group,
518                 (exists $changes{$position_column}
519                     # The FIXME bit contradicts the documentation: when changing groups without supplying explicit
520                     # positions in move_to_group(), we push the item to the end of the group.
521                     # However when I was rewriting this, the position from the old group was clearly passed to the new one
522                     # Probably needs to go away (by ribasushi)
523                     ? delete $changes{$position_column}     # means there was a position change supplied with the update too
524                     : $self->_position                      # FIXME!
525                 ),
526             );
527         }
528         elsif (exists $changes{$position_column}) {
529             $self->move_to(delete $changes{$position_column});
530         }
531
532         my @res;
533         my $want = wantarray();
534         if (not defined $want) {
535             $self->next::method( \%changes, @_ );
536         }
537         elsif ($want) {
538             @res = $self->next::method( \%changes, @_ );
539         }
540         else {
541             $res[0] = $self->next::method( \%changes, @_ );
542         }
543
544         $guard->commit;
545         return $want ? @res : $res[0];
546     }
547 }
548
549 =head2 delete
550
551 Overrides the DBIC delete() method by first moving the object 
552 to the last position, then deleting it, thus ensuring the
553 integrity of the positions.
554
555 =cut
556
557 sub delete {
558     my $self = shift;
559
560     my $guard = $self->result_source->schema->txn_scope_guard;
561
562     $self->move_last;
563
564     my @res;
565     my $want = wantarray();
566     if (not defined $want) {
567         $self->next::method( @_ );
568     }
569     elsif ($want) {
570         @res = $self->next::method( @_ );
571     }
572     else {
573         $res[0] = $self->next::method( @_ );
574     }
575
576     $guard->commit;
577     return $want ? @res : $res[0];
578 }
579
580 =head1 METHODS FOR EXTENDING ORDERED
581
582 You would want to override the methods below if you use sparse
583 (non-linear) or non-numeric position values. This can be useful
584 if you are working with preexisting non-normalised position data,
585 or if you need to work with materialized path columns.
586
587 =head2 _position
588
589   my $num_pos = $item->_position;
590
591 Returns the B<absolute numeric position> of the current object, with the
592 first object being at position 1, its sibling at position 2 and so on.
593 By default simply returns the value of L</position_column>.
594
595 =cut
596 sub _position {
597     my $self = shift;
598
599 #    #the right way to do this
600 #    return $self->previous_siblings->count + 1;
601
602     return $self->get_column ($self->position_column);
603 }
604
605 =head2 _position_value
606
607   my $pos_value = $item->_position_value ( $pos )
608
609 Returns the B<value> of L</position_column> of the object at numeric
610 position C<$pos>. By default simply returns C<$pos>.
611
612 =cut
613 sub _position_value {
614     my ($self, $pos) = @_;
615
616 #    #the right way to do this (not optimized)
617 #    my $position_column = $self->position_column;
618 #    return $self -> _group_rs
619 #                 -> search({}, { order_by => $position_column })
620 #                 -> slice ( $pos - 1)
621 #                 -> single
622 #                 -> get_column ($position_column);
623
624     return $pos;
625 }
626
627 =head2 _initial_position_value
628
629   __PACKAGE__->_initial_position_value(0);
630
631 This method specifies a B<value> of L</position_column> which is assigned
632 to the first inserted element of a group, if no value was supplied at
633 insertion time. All subsequent values are derived from this one by
634 L</_next_position_value> below. Defaults to 1.
635
636 =cut
637
638 __PACKAGE__->mk_classdata( '_initial_position_value' => 1 );
639
640 =head2 _next_position_value
641
642   my $new_value = $item->_next_position_value ( $position_value )
643
644 Returns a position B<value> that would be considered C<next> with
645 regards to C<$position_value>. Can be pretty much anything, given
646 that C<< $position_value < $new_value >> where C<< < >> is the
647 SQL comparison operator (usually works fine on strings). The
648 default method expects C<$position_value> to be numeric, and
649 returns C<$position_value + 1>
650
651 =cut
652 sub _next_position_value {
653     return $_[1] + 1;
654 }
655
656 =head2 _shift_siblings
657
658   $item->_shift_siblings ($direction, @between)
659
660 Shifts all siblings with B<positions values> in the range @between
661 (inclusive) by one position as specified by $direction (left if < 0,
662  right if > 0). By default simply increments/decrements each
663 L<position_column> value by 1, doing so in a way as to not violate
664 any existing constraints.
665
666 Note that if you override this method and have unique constraints
667 including the L<position_column> the shift is not a trivial task.
668 Refer to the implementation source of the default method for more
669 information.
670
671 =cut
672 sub _shift_siblings {
673     my ($self, $direction, @between) = @_;
674     return 0 unless $direction;
675
676     my $position_column = $self->position_column;
677
678     my ($op, $ord);
679     if ($direction < 0) {
680         $op = '-';
681         $ord = 'asc';
682     }
683     else {
684         $op = '+';
685         $ord = 'desc';
686     }
687
688     my $shift_rs = $self->_group_rs-> search ({ $position_column => { -between => \@between } });
689
690     # some databases (sqlite) are dumb and can not do a blanket
691     # increment/decrement. So what we do here is check if the
692     # position column is part of a unique constraint, and do a
693     # one-by-one update if this is the case
694
695     if (grep { $_ eq $position_column } ( map { @$_ } (values %{{ $self->result_source->unique_constraints }} ) ) ) {
696
697         my $rs = $shift_rs->search ({}, { order_by => { "-$ord", $position_column } } );
698         # FIXME - no need to inflate each row
699         while (my $r = $rs->next) {
700             $r->_ordered_internal_update ({ $position_column => \ "$position_column $op 1" } );
701         }
702     }
703     else {
704         $shift_rs->update ({ $position_column => \ "$position_column $op 1" } );
705     }
706 }
707
708 =head1 PRIVATE METHODS
709
710 These methods are used internally.  You should never have the 
711 need to use them.
712
713 =head2 _group_rs
714
715 This method returns a resultset containing all members of the row
716 group (including the row itself).
717
718 =cut
719 sub _group_rs {
720     my $self = shift;
721     return $self->result_source->resultset->search({$self->_grouping_clause()});
722 }
723
724 =head2 _siblings
725
726 Returns an unordered resultset of all objects in the same group
727 excluding the object you called this method on.
728
729 =cut
730 sub _siblings {
731     my $self = shift;
732     my $position_column = $self->position_column;
733     return $self->_group_rs->search(
734         { $position_column => { '!=' => $self->get_column($position_column) } },
735     );
736 }
737
738 =head2 _grouping_clause
739
740 This method returns one or more name=>value pairs for limiting a search
741 by the grouping column(s).  If the grouping column is not
742 defined then this will return an empty list.
743
744 =cut
745 sub _grouping_clause {
746     my( $self ) = @_;
747     return map {  $_ => $self->get_column($_)  } $self->_grouping_columns();
748 }
749
750 =head2 _get_grouping_columns
751
752 Returns a list of the column names used for grouping, regardless of whether
753 they were specified as an arrayref or a single string, and returns ()
754 if there is no grouping.
755
756 =cut
757 sub _grouping_columns {
758     my( $self ) = @_;
759     my $col = $self->grouping_column();
760     if (ref $col eq 'ARRAY') {
761         return @$col;
762     } elsif ($col) {
763         return ( $col );
764     } else {
765         return ();
766     }
767 }
768
769 =head2 _is_in_group
770
771     $item->_is_in_group( {user => 'fred', list => 'work'} )
772
773 Returns true if the object is in the group represented by hashref $other
774
775 =cut
776 sub _is_in_group {
777     my ($self, $other) = @_;
778     my $current = {$self->_grouping_clause};
779
780     no warnings qw/uninitialized/;
781
782     return 0 if (
783         join ("\x00", sort keys %$current)
784             ne
785         join ("\x00", sort keys %$other)
786     );
787     for my $key (keys %$current) {
788         return 0 if $current->{$key} ne $other->{$key};
789     }
790     return 1;
791 }
792
793 =head2 _ordered_internal_update
794
795 This is a short-circuited method, that is used internally by this
796 module to update positioning values in isolation (i.e. without
797 triggering any of the positioning integrity code).
798
799 Some day you might get confronted by datasets that have ambiguous
800 positioning data (i.e. duplicate position values within the same group,
801 in a table without unique constraints). When manually fixing such data
802 keep in mind that you can not invoke L<DBIx::Class::Row/update> like
803 you normally would, as it will get confused by the wrong data before
804 having a chance to update the ill-defined row. If you really know what
805 you are doing use this method which bypasses any hooks introduced by
806 this module.
807
808 =cut
809
810 sub _ordered_internal_update {
811     my $self = shift;
812     local $self->{_ORDERED_INTERNAL_UPDATE} = 1;
813     return $self->update (@_);
814 }
815
816 1;
817
818 __END__
819
820 =head1 CAVEATS
821
822 =head2 Race Condition on Insert
823
824 If a position is not specified for an insert than a position 
825 will be chosen based either on L</_initial_position_value> or
826 L</_next_position_value>, depending if there are already some
827 items in the current group. The space of time between the
828 necessary selects and insert introduces a race condition.
829 Having unique constraints on your position/group columns,
830 and using transactions (see L<DBIx::Class::Storage/txn_do>)
831 will prevent such race conditions going undetected.
832
833 =head2 Multiple Moves
834
835 Be careful when issueing move_* methods to multiple objects.  If 
836 you've pre-loaded the objects then when you move one of the objects 
837 the position of the other object will not reflect their new value 
838 until you reload them from the database - see
839 L<DBIx::Class::Row/discard_changes>.
840
841 There are times when you will want to move objects as groups, such 
842 as changeing the parent of several objects at once - this directly 
843 conflicts with this problem.  One solution is for us to write a 
844 ResultSet class that supports a parent() method, for example.  Another 
845 solution is to somehow automagically modify the objects that exist 
846 in the current object's result set to have the new position value.
847
848 =head2 Default Values
849
850 Using a database defined default_value on one of your group columns
851 could result in the position not being assigned correctly.
852
853 =head1 AUTHOR
854
855  Original code framework
856    Aran Deltac <bluefeet@cpan.org>
857
858  Constraints support and code generalisation
859    Peter Rabbitson <ribasushi@cpan.org>
860
861 =head1 LICENSE
862
863 You may distribute this code under the same terms as Perl itself.
864