File Coverage

blib/lib/Cz/Sort.pm
Criterion Covered Total %
statement 104 105 99.0
branch 71 82 86.5
condition 31 42 73.8
subroutine 9 9 100.0
pod 0 4 0.0
total 215 242 88.8


line stmt bran cond sub pod time code
1              
2             =head1 NAME
3              
4             Cz::Sort - Czech sort
5              
6             =cut
7              
8             #
9             # Here starts the Cz::Sort namespace
10             #
11             package Cz::Sort;
12 1     1   2206 no locale;
  1         292  
  1         5  
13 1     1   880 use integer;
  1         10  
  1         7  
14 1     1   25 use strict;
  1         6  
  1         38  
15 1     1   5 use Exporter;
  1         2  
  1         49  
16 1     1   5 use vars qw( @ISA @EXPORT $VERSION $DEBUG );
  1         1  
  1         1573  
17             @ISA = qw( Exporter );
18              
19             #
20             # We implicitly export czcmp, czsort, cscmp and cssort functions.
21             # Since these are the only ones that can be used by ordinary users,
22             # it should not cause big harm.
23             #
24             @EXPORT = qw( czsort czcmp cssort cscmp );
25              
26             $VERSION = '0.68';
27             $DEBUG = 0;
28 346     346 0 768 sub DEBUG { $DEBUG; }
29              
30             #
31             # The table with sorting definitions.
32             #
33             my @def_table = (
34             'aA áÁ â ãà äÄ ±¡',
35             'bB',
36             'cC æÆ çÇ', 'èÈ',
37             'dD ïÏ ðÐ',
38             'eE éÉ ìÌ ëË êÊ',
39             'fF',
40             'gG',
41             'hH',
42             '',
43             'iI íÍ îÎ',
44             'jJ',
45             'kK',
46             'lL åÅ µ¥ ³£',
47             'mM',
48             'nN ñÑ òÒ',
49             'oO óÓ ôÔ öÖ õÕ',
50             'pP',
51             'qQ',
52             'rR àÀ', 'øØ',
53             'sS ¶¦ ºª', '¹©',
54             'ß',
55             'tT »« þÞ',
56             'uU úÚ ùÙ üÜ ûÛ',
57             'vV',
58             'wW',
59             'xX',
60             'yY ýÝ',
61             'zZ ¿¯ ¼¬', '¾®',
62             '0', '1', '2', '3',
63             '4', '5', '6', '7',
64             '8', '9',
65             ' .,;?!:"`\'',
66             ' -­|/\\()[]<>{}',
67             ' @&§%$',
68             ' _^=+×*÷#¢~',
69             ' ÿ·°¨½¸²',
70             ' ¤',
71             );
72              
73             #
74             # Conversion table will hold four arrays, one for each pass. They will
75             # be created on the fly if they are needed. We also need to hold
76             # information (regexp) about groups of letters that need to be considered
77             # as one character (ch).
78             #
79             my @table = ( );
80             my @regexp = ( '.', '.', '.', '.' );
81             my @multiple = ( {}, {}, {}, {} );
82              
83             #
84             # Make_table will build sorting table for given level.
85             #
86             sub make_table
87             {
88 4     4 0 5 my $level = shift;
89 4         10 @{$table[$level]} = ( undef ) x 256;
  4         110  
90 4         7 @{$table[$level]}[ord ' ', ord "\t"] = (0, 0);
  4         11  
91 4         6 my $i = 1;
92 4         6 my $irow = 0;
93 4         15 while (defined $def_table[$irow])
94             {
95 192         230 my $def_row = $def_table[$irow];
96 192 100 100     712 next if $level <= 2 and $def_row =~ /^ /;
97 174         546 while ($def_row =~ /<([cC].*?)>|(.)/sg)
98             {
99 779         1143 my $match = $+;
100 779 100       1203 if ($match eq ' ')
101             {
102 150 100       508 if ($level == 1)
103 36         106 { $i++; }
104             }
105             else
106             {
107 629 100       970 if (length $match == 1)
108 617         1154 { $table[$level][ord $match] = $i; }
109             else
110             {
111 12         23 $multiple[$level]{$match} = $i;
112 12         23 $regexp[$level] = $match . "|" . $regexp[$level];
113             }
114 629 100       1662 if ($level >= 2)
115 337         974 { $i++; }
116             }
117             }
118 174 100       391 $i++ if $level < 2;
119             }
120             continue
121 192         408 { $irow++; }
122             }
123              
124             #
125             # Create the tables now.
126             #
127             for (0 .. 3)
128             { make_table($_); }
129              
130             #
131             # Compare two scalar, according to the tables.
132             #
133             sub czcmp
134             {
135 56     56 0 98 my ($a, $b) = (shift, shift);
136 56 50       81 print STDERR "czcmp: $a/$b\n" if DEBUG;
137 56         88 my ($a1, $b1) = ($a, $b);
138 56         59 my $level = 0;
139 56         54 while (1)
140             {
141 284         486 my ($ac, $bc, $a_no, $b_no, $ax, $bx) = ('', '', 0, 0,
142             undef, undef);
143 284 100       440 if ($level == 0)
144             {
145 237   66     676 while (not defined $ax and not $a_no)
146             {
147 240 100       941 $a =~ /$regexp[$level]/sg or $a_no = 1;
148 240         351 $ac = $&;
149 16         69 $ax = ( length $ac == 1 ?
150             $table[$level][ord $ac]
151 240 100       997 : ${$multiple[$level]}{$ac} )
    50          
152             if defined $ac;
153             }
154 237   66     720 while (not defined $bx and not $b_no)
155             {
156 240 100       2685 $b =~ /$regexp[$level]/sg or $b_no = 1;
157 240         349 $bc = $&;
158 16         91 $bx = ( length $bc == 1 ?
159             $table[$level][ord $bc]
160 240 100       896 : ${$multiple[$level]}{$bc} )
    50          
161             if defined $bc;
162             }
163             }
164             else
165             {
166 47   66     168 while (not defined $ax and not $a_no)
167             {
168 48 100       195 $a1 =~ /$regexp[$level]/sg or $a_no = 1;
169 48         71 $ac = $&;
170 4         19 $ax = ( length $ac == 1 ?
171             $table[$level][ord $ac]
172 48 100       203 : ${$multiple[$level]}{$ac} )
    50          
173             if defined $ac;
174             }
175 47   66     148 while (not defined $bx and not $b_no)
176             {
177 47 100       176 $b1 =~ /$regexp[$level]/sg or $b_no = 1;
178 47         67 $bc = $&;
179 4         18 $bx = ( length $bc == 1 ?
180             $table[$level][ord $bc]
181 47 100       184 : ${$multiple[$level]}{$bc} )
    50          
182             if defined $bc;
183             }
184             }
185              
186 284 50       440 print STDERR "level $level: ac: $ac -> $ax; bc: $bc -> $bx ($a_no, $b_no)\n" if DEBUG;
187              
188 284 100 100     8304 return -1 if $a_no and not $b_no;
189 278 100 100     988 return 1 if not $a_no and $b_no;
190 269 100 66     532 if ($a_no and $b_no)
191             {
192 10 100       23 if ($level == 0)
193 6         8 { $level = 1; next; }
  6         11  
194 4         11 last;
195             }
196              
197 259 100       513 return -1 if ($ax < $bx);
198 243 100       457 return 1 if ($ax > $bx);
199              
200 222 100 66     483 if ($ax == 0 and $bx == 0)
201             {
202 7 100       18 if ($level == 0)
203 4         5 { $level = 1; next; }
  4         8  
204 3         4 $level = 0; next;
  3         7  
205             }
206             }
207 4         12 for $level (2 .. 3)
208             {
209 5         6 while (1)
210             {
211 6         22 my ($ac, $bc, $a_no, $b_no, $ax, $bx)
212             = ('', '', 0, 0, undef, undef);
213 6   66     28 while (not defined $ax and not $a_no)
214             {
215 7 100       72 $a =~ /$regexp[$level]/sg or $a_no = 1;
216 7         17 $ac = $&;
217 1         5 $ax = ( length $ac == 1 ?
218             $table[$level][ord $ac]
219 7 100       38 : ${$multiple[$level]}{$ac} )
    50          
220             if defined $ac;
221             }
222 6   66     24 while (not defined $bx and not $b_no)
223             {
224 6 100       49 $b =~ /$regexp[$level]/sg or $b_no = 1;
225 6         11 $bc = $&;
226 1         6 $bx = ( length $bc == 1 ?
227             $table[$level][ord $bc]
228 6 100       32 : ${$multiple[$level]}{$bc} )
    50          
229             if defined $bc;
230             }
231            
232 6 50       16 print STDERR "level $level: ac: $ac -> $ax; bc: $bc -> $bx ($a_no, $b_no)\n" if DEBUG;
233 6 50 66     20 return -1 if $a_no and not $b_no;
234 6 50 66     42 return 1 if not $a_no and $b_no;
235 6 100 66     20 if ($a_no and $b_no)
236 1         9 { last; }
237 5 100       22 return -1 if ($ax < $bx);
238 3 100       15 return 1 if ($ax > $bx);
239             }
240             }
241 0         0 return 0;
242             }
243              
244             1;
245              
246             #
247             # Cssort does the real thing.
248             #
249             sub czsort
250 6     6 0 13114 { sort { my $result = czcmp($a, $b); } @_; }
  56         105  
251              
252             *cscmp = *czcmp;
253             *cssort = *czsort;
254              
255             1;
256              
257             __END__