File Coverage

web/cgi-bin/yatt.lib/YATT/Util/DictOrder.pm
Criterion Covered Total %
statement 21 22 95.4
branch 5 6 83.3
condition 3 6 50.0
subroutine 5 5 100.0
pod 2 2 100.0
total 36 41 87.8


line stmt bran cond sub pod time code
1             package YATT::Util::DictOrder;
2 10     10   37 use strict;
  10         619  
  10         288  
3 10     10   607 use warnings FATAL => qw(all);
  10         11  
  10         918  
4 10     10   30 use base qw/Exporter/;
  10         11  
  10         2898  
5              
6             our @EXPORT_OK = qw(&dict_order &dict_sort);
7             our @EXPORT = @EXPORT_OK;
8              
9             sub dict_order {
10 33     33 1 30 my ($a, $b, $start) = @_;
11 33 50       38 $start = 1 unless defined $start;
12 33         28 my ($result, $i) = (0);
13 33   33     82 for ($i = $start; $i <= $#$a and $i <= $#$b; $i++) {
14 66 100 66     145 if ($a->[$i] =~ /^\d/ and $b->[$i] =~ /^\d/) {
15 33         34 $result = $a->[$i] <=> $b->[$i];
16             } else {
17 33         31 $result = $a->[$i] cmp $b->[$i];
18             }
19 66 100       148 return $result unless $result == 0;
20             }
21 0         0 return $#$a <=> $#$b;
22             }
23              
24             # a => ['a', 'a']
25             # q1a => ['q1a', 'q', 1, 'a']
26             # q11b => ['q11b', 'q', 11, 'b']
27             sub dict_sort (@) {
28 1     1 1 4 map {$_->[0]} sort {dict_order($a,$b)} map {[$_, split /(\d+)/]} @_;
  13         15  
  33         29  
  13         43  
29             }
30              
31             1;
32              
33             =head1 NAME
34              
35             YATT::Util::DictOrder - Dictionary-style ordering and sorting.
36              
37             =head1 SYNOPSIS
38              
39             use YATT::Util::DictOrder;
40             print join ",", dict_sort qw(q3-1 q3 q10a q1);
41             # prints "q1,q3,q3-1,q10a"
42              
43             print join ",",
44             map {$$_[0]}
45             sort {dict_order($a, $b, 1)}
46             map {[$$_[0], split /(\d+)/, $$_[1]]}
47             [qw(foo q3-1)],
48             [qw(summer q3)],
49             [qw(moe q10a)],
50             [qw(romantic q1)];
51             # prints "romantic,summer,foo,moe"
52              
53             =head1 DESCRIPTION
54              
55             =head2 C
56              
57             =head2 C
58              
59             =head1 AUTHOR
60              
61             KOBAYASI, Hiroaki (C)
62              
63             =head1 LICENSE
64              
65             This library is free software; you may redistribute it and/or modify
66             it under the same terms as Perl itself.
67              
68             =cut