line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Sort::Maker; |
2
|
|
|
|
|
|
|
|
3
|
23
|
|
|
23
|
|
648840
|
use strict; |
|
23
|
|
|
|
|
119
|
|
|
23
|
|
|
|
|
1074
|
|
4
|
21
|
|
|
21
|
|
250
|
use base qw(Exporter); |
|
21
|
|
|
|
|
2807
|
|
|
21
|
|
|
|
|
3709
|
|
5
|
|
|
|
|
|
|
|
6
|
21
|
|
|
21
|
|
2293
|
use Data::Dumper ; |
|
21
|
|
|
|
|
27659
|
|
|
21
|
|
|
|
|
13906
|
|
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
our @EXPORT = qw( make_sorter ); |
9
|
|
|
|
|
|
|
our %EXPORT_TAGS = ( 'all' => [ qw( sorter_source ), @EXPORT ] ); |
10
|
|
|
|
|
|
|
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
our $VERSION = '0.06'; |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
# get integer and float sizes endian order |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
my $FLOAT_LEN = length pack "d", 1 ; |
18
|
|
|
|
|
|
|
my $INT_LEN = length pack "N", 1 ; |
19
|
|
|
|
|
|
|
my $INT_BIT_LEN = $INT_LEN * 8 ; |
20
|
|
|
|
|
|
|
my $IS_BIG_ENDIAN = pack('N', 1) eq pack('L', 1) ; |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
my @boolean_attrs = qw( |
23
|
|
|
|
|
|
|
ascending |
24
|
|
|
|
|
|
|
descending |
25
|
|
|
|
|
|
|
case |
26
|
|
|
|
|
|
|
no_case |
27
|
|
|
|
|
|
|
signed |
28
|
|
|
|
|
|
|
unsigned |
29
|
|
|
|
|
|
|
signed_float |
30
|
|
|
|
|
|
|
unsigned_float |
31
|
|
|
|
|
|
|
varying |
32
|
|
|
|
|
|
|
closure |
33
|
|
|
|
|
|
|
) ; |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
my @value_attrs = qw( |
36
|
|
|
|
|
|
|
fixed |
37
|
|
|
|
|
|
|
) ; |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
my @grt_num_attrs = qw( |
40
|
|
|
|
|
|
|
signed |
41
|
|
|
|
|
|
|
unsigned |
42
|
|
|
|
|
|
|
signed_float |
43
|
|
|
|
|
|
|
unsigned_float |
44
|
|
|
|
|
|
|
) ; |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
my @grt_string_attrs = qw( |
47
|
|
|
|
|
|
|
varying |
48
|
|
|
|
|
|
|
fixed |
49
|
|
|
|
|
|
|
) ; |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
# these key attributes set are mutually exclusive |
52
|
|
|
|
|
|
|
# only one can be set in the defaults or in any given key |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
my @mutex_attrs = ( |
55
|
|
|
|
|
|
|
[qw(case no_case)], |
56
|
|
|
|
|
|
|
[qw(ascending descending)], |
57
|
|
|
|
|
|
|
\@grt_num_attrs, |
58
|
|
|
|
|
|
|
\@grt_string_attrs, |
59
|
|
|
|
|
|
|
) ; |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
# code can only be an attribute and not a default attribute argument |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
my %is_boolean_attr = map { $_ => 1 } @boolean_attrs ; |
65
|
|
|
|
|
|
|
my %is_value_attr = map { $_ => 1 } @value_attrs, 'code' ; |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
my @boolean_args = qw( |
68
|
|
|
|
|
|
|
ref_in |
69
|
|
|
|
|
|
|
ref_out |
70
|
|
|
|
|
|
|
string_data |
71
|
|
|
|
|
|
|
) ; |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
my @value_args = qw( |
74
|
|
|
|
|
|
|
name |
75
|
|
|
|
|
|
|
init_code |
76
|
|
|
|
|
|
|
) ; |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
# all the attributes can be set with defaults |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
my %is_boolean_arg = map { $_ => 1 } @boolean_args, @boolean_attrs ; |
81
|
|
|
|
|
|
|
my %is_value_arg = map { $_ => 1 } @value_args, @value_attrs ; |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
my @key_types = qw( |
84
|
|
|
|
|
|
|
string |
85
|
|
|
|
|
|
|
number |
86
|
|
|
|
|
|
|
) ; |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
my %is_key_arg = map { $_ => 1 } @key_types ; |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
my %sort_makers = ( |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
plain => \&_make_plain_sort, |
93
|
|
|
|
|
|
|
orcish => \&_make_orcish_sort, |
94
|
|
|
|
|
|
|
ST => \&_make_ST_sort, |
95
|
|
|
|
|
|
|
GRT => \&_make_GRT_sort, |
96
|
|
|
|
|
|
|
) ; |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
my %is_arg = ( %is_key_arg, %sort_makers, %is_value_arg, %is_boolean_arg ) ; |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
my %sources ; |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
# this is a file lexical so the WARN handler sub can see it. |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
my $eval_warnings = '' ; |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
sub make_sorter { |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
# clear any leftover errors |
109
|
|
|
|
|
|
|
|
110
|
248
|
|
|
248
|
1
|
236677
|
$@ = '' ; |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
# process @_ without copying it (&sub with no args) |
113
|
|
|
|
|
|
|
|
114
|
248
|
|
|
|
|
481
|
my( $options, $keys, $closures ) = &_process_arguments ; |
115
|
248
|
100
|
|
|
|
700
|
return unless $keys ; |
116
|
|
|
|
|
|
|
|
117
|
238
|
|
|
|
|
480
|
my @closures = _get_extractor_code( $options, $keys ) ; |
118
|
|
|
|
|
|
|
|
119
|
238
|
100
|
|
|
|
478
|
return if $@ ; |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
# get the sort maker for this style and build the sorter |
122
|
|
|
|
|
|
|
|
123
|
237
|
|
|
|
|
698
|
my $sort_maker = $sort_makers{ $options->{style} } ; |
124
|
237
|
|
|
|
|
580
|
my $source = $sort_maker->( $options, $keys ) ; |
125
|
237
|
100
|
|
|
|
550
|
return unless $source ; |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
# prepend code to access any closures |
128
|
|
|
|
|
|
|
|
129
|
236
|
100
|
|
|
|
860
|
if ( @closures ) { |
130
|
|
|
|
|
|
|
|
131
|
15
|
|
|
|
|
73
|
my $closure_text = join '', map <
|
132
|
|
|
|
|
|
|
my \$closure$_ = \$closures[$_] ; |
133
|
|
|
|
|
|
|
CLOSURE |
134
|
|
|
|
|
|
|
|
135
|
15
|
|
|
|
|
47
|
$source = "use strict ;\n$closure_text\n$source" ; |
136
|
|
|
|
|
|
|
} |
137
|
|
|
|
|
|
|
|
138
|
236
|
|
|
|
|
498
|
my $sorter = do { |
139
|
236
|
|
|
3
|
|
1480
|
local( $SIG{__WARN__} ) = sub { $eval_warnings .= $_[0] } ; |
|
3
|
|
|
|
|
6
|
|
140
|
18
|
|
|
18
|
|
169
|
eval $source ; |
|
18
|
|
|
17
|
|
42
|
|
|
18
|
|
|
15
|
|
1474
|
|
|
17
|
|
|
15
|
|
149
|
|
|
17
|
|
|
9
|
|
32
|
|
|
17
|
|
|
9
|
|
2006
|
|
|
15
|
|
|
9
|
|
101
|
|
|
15
|
|
|
9
|
|
29
|
|
|
15
|
|
|
1
|
|
1166
|
|
|
15
|
|
|
|
|
78
|
|
|
15
|
|
|
|
|
32
|
|
|
15
|
|
|
|
|
1649
|
|
|
9
|
|
|
|
|
65
|
|
|
9
|
|
|
|
|
29
|
|
|
9
|
|
|
|
|
395
|
|
|
9
|
|
|
|
|
51
|
|
|
9
|
|
|
|
|
17
|
|
|
9
|
|
|
|
|
818
|
|
|
9
|
|
|
|
|
64
|
|
|
9
|
|
|
|
|
19
|
|
|
9
|
|
|
|
|
424
|
|
|
9
|
|
|
|
|
47
|
|
|
9
|
|
|
|
|
17
|
|
|
9
|
|
|
|
|
880
|
|
|
236
|
|
|
|
|
40041
|
|
|
1
|
|
|
|
|
38
|
|
|
4
|
|
|
|
|
5
|
|
|
4
|
|
|
|
|
7
|
|
|
8
|
|
|
|
|
14
|
|
|
4
|
|
|
|
|
11
|
|
141
|
|
|
|
|
|
|
} ; |
142
|
|
|
|
|
|
|
|
143
|
236
|
|
100
|
|
|
6105
|
$sources{ $sorter || '' } = $source ; |
144
|
|
|
|
|
|
|
|
145
|
236
|
100
|
|
|
|
536
|
$@ = <
|
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
sort_maker: Can't compile this source for style $options->{style}. |
148
|
|
|
|
|
|
|
Check the key extraction code for errors. |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
$source |
151
|
|
|
|
|
|
|
$eval_warnings |
152
|
|
|
|
|
|
|
$@ |
153
|
|
|
|
|
|
|
ERR |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
# install the sorter sub in the caller's package if a name was set |
156
|
|
|
|
|
|
|
|
157
|
231
|
100
|
|
|
|
977
|
if ( my $name = $options->{name} ) { |
158
|
|
|
|
|
|
|
|
159
|
20
|
|
|
20
|
|
134
|
no strict 'refs' ; |
|
20
|
|
|
|
|
35
|
|
|
20
|
|
|
|
|
60461
|
|
160
|
|
|
|
|
|
|
|
161
|
4
|
|
|
|
|
24
|
my $package = (caller())[0] ; |
162
|
|
|
|
|
|
|
|
163
|
4
|
|
|
|
|
16
|
*{"${package}::$name"} = $sorter ; |
|
4
|
|
|
|
|
270
|
|
164
|
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
|
|
166
|
231
|
|
|
|
|
2798
|
return $sorter ; |
167
|
|
|
|
|
|
|
} |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
sub _process_arguments { |
170
|
|
|
|
|
|
|
|
171
|
248
|
|
|
248
|
|
326
|
my( %options, @keys ) ; |
172
|
|
|
|
|
|
|
|
173
|
248
|
|
|
|
|
968
|
while( @_ ) { |
174
|
|
|
|
|
|
|
|
175
|
722
|
|
|
|
|
893
|
my $opt = shift ; |
176
|
|
|
|
|
|
|
|
177
|
722
|
100
|
|
|
|
1641
|
if ( $sort_makers{ $opt } ) { |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
$@ = |
180
|
|
|
|
|
|
|
"make_sorter: Style was already set to '$options{ style }'", |
181
|
243
|
100
|
|
|
|
643
|
return if $options{ style } ; |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
# handle optional boolean => 1 |
184
|
242
|
50
|
66
|
|
|
1315
|
shift if @_ && $_[0] eq '1' ; |
185
|
242
|
|
|
|
|
533
|
$options{ style } = $opt ; |
186
|
242
|
|
|
|
|
496
|
$options{ $opt } = 1 ; |
187
|
|
|
|
|
|
|
|
188
|
242
|
|
|
|
|
586
|
next ; |
189
|
|
|
|
|
|
|
} |
190
|
|
|
|
|
|
|
|
191
|
479
|
100
|
|
|
|
1213
|
if ( $is_boolean_arg{ $opt } ) { |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
# handle optional boolean => 1 |
194
|
194
|
50
|
66
|
|
|
668
|
shift if @_ && $_[0] eq '1' ; |
195
|
194
|
|
|
|
|
298
|
$options{ $opt } = 1 ; |
196
|
194
|
|
|
|
|
405
|
next ; |
197
|
|
|
|
|
|
|
} |
198
|
|
|
|
|
|
|
|
199
|
285
|
100
|
|
|
|
858
|
if ( $is_value_arg{ $opt } ) { |
200
|
|
|
|
|
|
|
|
201
|
11
|
100
|
|
|
|
33
|
$@ = "make_sorter: No value for argument '$opt'\n", |
202
|
|
|
|
|
|
|
return unless @_ ; |
203
|
|
|
|
|
|
|
|
204
|
10
|
|
|
|
|
19
|
$options{ $opt } = shift ; |
205
|
10
|
|
|
|
|
26
|
next ; |
206
|
|
|
|
|
|
|
} |
207
|
|
|
|
|
|
|
|
208
|
274
|
100
|
|
|
|
648
|
if ( $is_key_arg{ $opt } ) { |
209
|
|
|
|
|
|
|
|
210
|
273
|
|
|
|
|
367
|
my $key_desc = $_[0] ; |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
# if we have no key value or it is an option, we just have a single key. |
213
|
|
|
|
|
|
|
|
214
|
273
|
100
|
100
|
|
|
1189
|
if ( !defined( $key_desc ) || $is_arg{ $key_desc } ) { |
215
|
|
|
|
|
|
|
|
216
|
137
|
|
|
|
|
398
|
push( @keys, { |
217
|
|
|
|
|
|
|
type => $opt, |
218
|
|
|
|
|
|
|
} |
219
|
|
|
|
|
|
|
) ; |
220
|
|
|
|
|
|
|
|
221
|
137
|
|
|
|
|
364
|
next ; |
222
|
|
|
|
|
|
|
} |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
# if we have a hash ref for the value, it is the description for this key |
225
|
|
|
|
|
|
|
|
226
|
136
|
100
|
|
|
|
299
|
if( ref $key_desc eq 'HASH' ) { |
227
|
|
|
|
|
|
|
|
228
|
2
|
|
|
|
|
3
|
shift @_ ; |
229
|
2
|
|
|
|
|
5
|
$key_desc->{type} = $opt ; |
230
|
2
|
|
|
|
|
2
|
push( @keys, $key_desc ) ; |
231
|
2
|
|
|
|
|
6
|
next ; |
232
|
|
|
|
|
|
|
} |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
# if we have an array ref for the value, it is the description for this key |
235
|
|
|
|
|
|
|
|
236
|
134
|
100
|
|
|
|
281
|
if( ref $key_desc eq 'ARRAY' ) { |
237
|
|
|
|
|
|
|
|
238
|
3
|
|
|
|
|
3
|
$key_desc = _process_array_attrs(@{$key_desc}) ; |
|
3
|
|
|
|
|
11
|
|
239
|
3
|
50
|
|
|
|
16
|
return unless $key_desc ; |
240
|
|
|
|
|
|
|
|
241
|
0
|
|
|
|
|
0
|
shift @_ ; |
242
|
0
|
|
|
|
|
0
|
$key_desc->{type} = $opt ; |
243
|
0
|
|
|
|
|
0
|
push( @keys, $key_desc ) ; |
244
|
0
|
|
|
|
|
0
|
next ; |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
# not a hash ref or an option/key so it must be code for the key |
248
|
|
|
|
|
|
|
|
249
|
131
|
|
|
|
|
135
|
shift ; |
250
|
131
|
|
|
|
|
419
|
push( @keys, { |
251
|
|
|
|
|
|
|
type => $opt, |
252
|
|
|
|
|
|
|
code => $key_desc, |
253
|
|
|
|
|
|
|
} |
254
|
|
|
|
|
|
|
) ; |
255
|
131
|
|
|
|
|
372
|
next ; |
256
|
|
|
|
|
|
|
} |
257
|
|
|
|
|
|
|
|
258
|
1
|
|
|
|
|
3
|
$@ = "make_sorter: Unknown option or key '$opt'\n" ; |
259
|
1
|
|
|
|
|
4
|
return ; |
260
|
|
|
|
|
|
|
} |
261
|
|
|
|
|
|
|
|
262
|
239
|
100
|
|
|
|
505
|
unless( @keys ) { |
263
|
1
|
|
|
|
|
10
|
$@ = 'make_sorter: No keys specified' ; |
264
|
1
|
|
|
|
|
3
|
return ; |
265
|
|
|
|
|
|
|
} |
266
|
|
|
|
|
|
|
|
267
|
238
|
100
|
|
|
|
559
|
unless( $options{style} ) { |
268
|
1
|
|
|
|
|
3
|
$@ = 'make_sorter: No sort style selected' ; |
269
|
1
|
|
|
|
|
10
|
return ; |
270
|
|
|
|
|
|
|
} |
271
|
|
|
|
|
|
|
|
272
|
237
|
100
|
|
|
|
709
|
return unless _process_defaults( \%options, \@keys ) ; |
273
|
|
|
|
|
|
|
|
274
|
235
|
|
|
|
|
612
|
return( \%options, \@keys ) ; |
275
|
|
|
|
|
|
|
} |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
sub _process_defaults { |
278
|
|
|
|
|
|
|
|
279
|
237
|
|
|
240
|
|
353
|
my( $opts, $keys ) = @_ ; |
280
|
|
|
|
|
|
|
|
281
|
237
|
50
|
|
|
|
6345
|
return if _has_mutex_attrs( $opts, 'defaults have' ) ; |
282
|
|
|
|
|
|
|
|
283
|
237
|
|
100
|
|
|
996
|
$opts->{init_code} ||= '' ; |
284
|
|
|
|
|
|
|
|
285
|
237
|
|
|
|
|
255
|
foreach my $key ( @{$keys} ) { |
|
237
|
|
|
|
|
399
|
|
286
|
|
|
|
|
|
|
|
287
|
269
|
100
|
|
|
|
489
|
return if _has_mutex_attrs( $key, 'key has' ) ; |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
# set descending if it is not ascending and the default is descending. |
290
|
|
|
|
|
|
|
|
291
|
267
|
|
66
|
|
|
1726
|
$key->{'descending'} ||= |
|
|
|
66
|
|
|
|
|
292
|
|
|
|
|
|
|
!$key->{'ascending'} && $opts->{'descending'} ; |
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
# set no_case if it is not case and the default is no_case. |
295
|
|
|
|
|
|
|
|
296
|
267
|
|
66
|
|
|
1579
|
$key->{'no_case'} ||= |
|
|
|
66
|
|
|
|
|
297
|
|
|
|
|
|
|
!$key->{'case'} && $opts->{'no_case'} ; |
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
# handle GRT default attrs, both number and string |
300
|
|
|
|
|
|
|
# don't use the default if an attribute is set in the key |
301
|
|
|
|
|
|
|
|
302
|
267
|
50
|
|
|
|
1039
|
unless( grep( $key->{$_}, @grt_num_attrs ) ) { |
303
|
|
|
|
|
|
|
|
304
|
267
|
|
|
|
|
328
|
@{$key}{@grt_num_attrs} = @{$opts}{@grt_num_attrs} ; |
|
267
|
|
|
|
|
935
|
|
|
267
|
|
|
|
|
578
|
|
305
|
|
|
|
|
|
|
} |
306
|
|
|
|
|
|
|
|
307
|
267
|
50
|
|
|
|
917
|
unless( grep( $key->{$_}, @grt_string_attrs ) ) { |
308
|
|
|
|
|
|
|
|
309
|
267
|
|
|
|
|
991
|
@{$key}{@grt_string_attrs} = |
|
267
|
|
|
|
|
436
|
|
310
|
267
|
|
|
|
|
346
|
@{$opts}{@grt_string_attrs} ; |
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
} |
313
|
|
|
|
|
|
|
|
314
|
235
|
|
|
|
|
920
|
return 1 ; |
315
|
|
|
|
|
|
|
} |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
sub _get_extractor_code { |
319
|
|
|
|
|
|
|
|
320
|
235
|
|
|
238
|
|
313
|
my( $opts, $keys ) = @_ ; |
321
|
|
|
|
|
|
|
|
322
|
235
|
|
|
|
|
257
|
my( @closures, $deparser ) ; |
323
|
|
|
|
|
|
|
|
324
|
235
|
|
|
|
|
245
|
foreach my $key ( @{$keys} ) { |
|
235
|
|
|
|
|
396
|
|
325
|
|
|
|
|
|
|
|
326
|
267
|
|
|
|
|
403
|
my $extract_code = $key->{code} ; |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
# default extract code is $_ |
329
|
|
|
|
|
|
|
|
330
|
267
|
100
|
|
|
|
506
|
unless( $extract_code ) { |
331
|
|
|
|
|
|
|
|
332
|
136
|
|
|
|
|
223
|
$key->{code} = '$_' ; |
333
|
136
|
|
|
|
|
291
|
next ; |
334
|
|
|
|
|
|
|
} |
335
|
|
|
|
|
|
|
|
336
|
131
|
|
|
|
|
180
|
my $extractor_type = ref $extract_code ; |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
# leave the extractor code alone if it is a string |
339
|
|
|
|
|
|
|
|
340
|
131
|
100
|
|
|
|
345
|
next unless $extractor_type ; |
341
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
# wrap regexes in m() |
343
|
|
|
|
|
|
|
|
344
|
41
|
100
|
|
|
|
88
|
if( $extractor_type eq 'Regexp' ) { |
345
|
|
|
|
|
|
|
|
346
|
8
|
|
|
|
|
21
|
$key->{code} = "m($extract_code)" ; |
347
|
8
|
|
|
|
|
25
|
next ; |
348
|
|
|
|
|
|
|
} |
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
# return an error if it is not a CODE ref |
351
|
|
|
|
|
|
|
|
352
|
33
|
100
|
|
|
|
64
|
unless( $extractor_type eq 'CODE' ) { |
353
|
|
|
|
|
|
|
|
354
|
1
|
|
|
|
|
8
|
$@ = "$extract_code is not a CODE or Regexp reference" ; |
355
|
1
|
|
|
|
|
3
|
return ; |
356
|
|
|
|
|
|
|
} |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
# must be a code reference |
359
|
|
|
|
|
|
|
# see if it is a closure |
360
|
|
|
|
|
|
|
|
361
|
32
|
100
|
66
|
|
|
125
|
if ( $opts->{closure} || $key->{closure} ) { |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
# generate the code that will call this closure |
364
|
|
|
|
|
|
|
|
365
|
16
|
|
|
|
|
21
|
my $n = @closures ; |
366
|
16
|
|
|
|
|
38
|
$key->{code} = "\$closure$n->()" ; |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
#print "CODE $key->{code}\n" ; |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
# copy the closure so we can process them later |
371
|
|
|
|
|
|
|
|
372
|
16
|
|
|
|
|
20
|
push @closures, $extract_code ; |
373
|
16
|
|
|
|
|
32
|
next ; |
374
|
|
|
|
|
|
|
} |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
# Otherwise, try to decompile the code ref with B::Deparse... |
377
|
|
|
|
|
|
|
|
378
|
16
|
50
|
|
|
|
107
|
unless( require B::Deparse ) { |
379
|
|
|
|
|
|
|
|
380
|
0
|
|
|
|
|
0
|
$@ = <
|
381
|
|
|
|
|
|
|
Can't use CODE as key extractor unless B::Deparse module installed |
382
|
|
|
|
|
|
|
ERR |
383
|
0
|
|
|
|
|
0
|
return ; |
384
|
|
|
|
|
|
|
} |
385
|
|
|
|
|
|
|
|
386
|
16
|
|
33
|
|
|
723
|
$deparser ||= B::Deparse->new("-p", "-sC"); |
387
|
|
|
|
|
|
|
|
388
|
16
|
|
|
|
|
21
|
my $source = eval { $deparser->coderef2text( $extract_code ) } ; |
|
16
|
|
|
|
|
14400
|
|
389
|
|
|
|
|
|
|
|
390
|
16
|
50
|
|
|
|
52
|
unless( $source ) { |
391
|
|
|
|
|
|
|
|
392
|
0
|
|
|
|
|
0
|
$@ = "Can't use [$extract_code] as key extractor"; |
393
|
0
|
|
|
|
|
0
|
return ; |
394
|
|
|
|
|
|
|
} |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
#print "S [$source]\n" ; |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
# use just the juicy pulp inside the braces... |
399
|
|
|
|
|
|
|
|
400
|
16
|
|
|
|
|
59
|
$key->{code} = "do $source" ; |
401
|
|
|
|
|
|
|
} |
402
|
|
|
|
|
|
|
|
403
|
234
|
|
|
|
|
735
|
return @closures ; |
404
|
|
|
|
|
|
|
} |
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
# this is used to check for any mutually exclusive attribute in |
408
|
|
|
|
|
|
|
# defaults or keys |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
sub _has_mutex_attrs { |
411
|
|
|
|
|
|
|
|
412
|
506
|
|
|
509
|
|
735
|
my( $href, $name ) = @_ ; |
413
|
|
|
|
|
|
|
|
414
|
506
|
|
|
|
|
707
|
foreach my $mutex ( @mutex_attrs ) { |
415
|
|
|
|
|
|
|
|
416
|
2019
|
|
|
|
|
1891
|
my @bad_attrs = grep $href->{$_}, @{$mutex} ; |
|
2019
|
|
|
|
|
5648
|
|
417
|
|
|
|
|
|
|
|
418
|
2019
|
100
|
|
|
|
5097
|
next if @bad_attrs <= 1 ; |
419
|
|
|
|
|
|
|
|
420
|
2
|
|
|
|
|
6
|
$@ = "make_sorter: Key attribute conflict: '$name @bad_attrs'"; |
421
|
2
|
|
|
|
|
20
|
return 1 ; |
422
|
|
|
|
|
|
|
} |
423
|
|
|
|
|
|
|
|
424
|
504
|
|
|
|
|
1346
|
return ; |
425
|
|
|
|
|
|
|
} |
426
|
|
|
|
|
|
|
|
427
|
|
|
|
|
|
|
sub _process_array_attrs { |
428
|
|
|
|
|
|
|
|
429
|
3
|
|
|
6
|
|
6
|
my( @attrs ) = @_ ; |
430
|
|
|
|
|
|
|
|
431
|
3
|
|
|
|
|
5
|
my $desc ; |
432
|
|
|
|
|
|
|
|
433
|
3
|
|
|
|
|
9
|
while( @attrs ) { |
434
|
|
|
|
|
|
|
|
435
|
6
|
|
|
|
|
9
|
my $attr = shift @attrs ; |
436
|
|
|
|
|
|
|
|
437
|
|
|
|
|
|
|
#print "ATTR $attr\n" ; |
438
|
|
|
|
|
|
|
|
439
|
6
|
100
|
|
|
|
15
|
if ( $is_boolean_attr{ $attr } ) { |
440
|
|
|
|
|
|
|
|
441
|
4
|
50
|
|
|
|
9
|
shift @attrs if $attrs[0] eq '1' ; |
442
|
4
|
|
|
|
|
15
|
$desc->{ $attr } = 1 ; |
443
|
4
|
|
|
|
|
19
|
next ; |
444
|
|
|
|
|
|
|
} |
445
|
|
|
|
|
|
|
|
446
|
2
|
100
|
|
|
|
6
|
if ( $is_value_attr{ $attr } ) { |
447
|
|
|
|
|
|
|
|
448
|
1
|
50
|
|
|
|
5
|
$@ = "make_sorter: No value for attribute '$attr'", |
449
|
|
|
|
|
|
|
return unless @attrs ; |
450
|
|
|
|
|
|
|
|
451
|
0
|
|
|
|
|
0
|
$desc->{ $attr } = shift @attrs ; |
452
|
0
|
|
|
|
|
0
|
next ; |
453
|
|
|
|
|
|
|
} |
454
|
|
|
|
|
|
|
|
455
|
1
|
|
|
|
|
4
|
$@ = "make_sorter: Unknown attribute '$attr'" ; |
456
|
1
|
|
|
|
|
3
|
return ; |
457
|
|
|
|
|
|
|
} |
458
|
|
|
|
|
|
|
|
459
|
1
|
|
|
|
|
2
|
return( $desc ) ; |
460
|
|
|
|
|
|
|
} |
461
|
|
|
|
|
|
|
|
462
|
|
|
|
|
|
|
sub _make_plain_sort { |
463
|
|
|
|
|
|
|
|
464
|
49
|
|
|
52
|
|
85
|
my( $options, $keys ) = @_ ; |
465
|
|
|
|
|
|
|
|
466
|
49
|
|
|
|
|
70
|
my( @plain_compares ) ; |
467
|
|
|
|
|
|
|
|
468
|
49
|
|
|
|
|
81
|
foreach my $key ( @{$keys} ) { |
|
49
|
|
|
|
|
99
|
|
469
|
|
|
|
|
|
|
|
470
|
54
|
|
|
|
|
130
|
my $plain_compare = <
|
471
|
|
|
|
|
|
|
do{ my( \$left, \$right ) = map { EXTRACT } \$a, \$b; |
472
|
|
|
|
|
|
|
uc \$left cmp uc \$right } |
473
|
|
|
|
|
|
|
CMP |
474
|
|
|
|
|
|
|
|
475
|
54
|
100
|
|
|
|
206
|
$plain_compare =~ s/\$a, \$b/\$b, \$a/ if $key->{descending} ; |
476
|
54
|
100
|
|
|
|
286
|
$plain_compare =~ s/cmp/<=>/ if $key->{type} eq 'number' ; |
477
|
54
|
50
|
66
|
|
|
432
|
$plain_compare =~ s/uc //g |
478
|
|
|
|
|
|
|
unless $key->{type} eq 'string' && $key->{no_case} ; |
479
|
54
|
|
|
|
|
348
|
$plain_compare =~ s/EXTRACT/$key->{code}/ ; |
480
|
|
|
|
|
|
|
|
481
|
54
|
|
|
|
|
202
|
push( @plain_compares, $plain_compare ) ; |
482
|
|
|
|
|
|
|
} |
483
|
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
# build the full compare block |
485
|
|
|
|
|
|
|
|
486
|
49
|
|
|
|
|
157
|
my $compare_source = join "\t\t||\n", @plain_compares ; |
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
# handle the in/out as ref options |
489
|
|
|
|
|
|
|
|
490
|
49
|
100
|
|
|
|
189
|
my $input = $options->{ref_in} ? '@{$_[0]}' : '@_' ; |
491
|
49
|
100
|
|
|
|
179
|
my( $open_bracket, $close_bracket ) = $options->{ref_out} ? |
492
|
|
|
|
|
|
|
qw( [ ] ) : ( '', '' ) ; |
493
|
|
|
|
|
|
|
|
494
|
49
|
|
|
|
|
246
|
my $source = <
|
495
|
|
|
|
|
|
|
sub { |
496
|
|
|
|
|
|
|
use strict ; |
497
|
|
|
|
|
|
|
use warnings ; |
498
|
|
|
|
|
|
|
$options->{init_code} |
499
|
|
|
|
|
|
|
$open_bracket |
500
|
|
|
|
|
|
|
sort { |
501
|
|
|
|
|
|
|
$compare_source |
502
|
|
|
|
|
|
|
} $input $close_bracket ; |
503
|
|
|
|
|
|
|
} |
504
|
|
|
|
|
|
|
SUB |
505
|
|
|
|
|
|
|
|
506
|
49
|
|
|
|
|
152
|
return $source ; |
507
|
|
|
|
|
|
|
} |
508
|
|
|
|
|
|
|
|
509
|
|
|
|
|
|
|
sub _make_orcish_sort { |
510
|
|
|
|
|
|
|
|
511
|
47
|
|
|
47
|
|
85
|
my( $options, $keys ) = @_ ; |
512
|
|
|
|
|
|
|
|
513
|
47
|
|
|
|
|
65
|
my( @orcish_compares ) ; |
514
|
|
|
|
|
|
|
|
515
|
47
|
|
|
|
|
82
|
my $orc_ind = '1' ; |
516
|
|
|
|
|
|
|
|
517
|
47
|
|
|
|
|
61
|
foreach my $key ( @{$keys} ) { |
|
47
|
|
|
|
|
90
|
|
518
|
|
|
|
|
|
|
|
519
|
52
|
100
|
|
|
|
188
|
my( $l, $r ) = $key->{descending} ? qw( $b $a ) : qw( $a $b ) ; |
520
|
|
|
|
|
|
|
|
521
|
52
|
|
|
|
|
223
|
my $orcish_compare = <
|
522
|
|
|
|
|
|
|
( |
523
|
|
|
|
|
|
|
( \$or_cache$orc_ind\{$l} ||= |
524
|
|
|
|
|
|
|
do{ my (\$val) = map { EXTRACT } $l ; uc \$val } ) |
525
|
|
|
|
|
|
|
cmp |
526
|
|
|
|
|
|
|
( \$or_cache$orc_ind\{$r} ||= |
527
|
|
|
|
|
|
|
do{ my (\$val) = map { EXTRACT } $r ; uc \$val } ) |
528
|
|
|
|
|
|
|
) |
529
|
|
|
|
|
|
|
CMP |
530
|
|
|
|
|
|
|
|
531
|
52
|
|
|
|
|
105
|
$orc_ind++ ; |
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
# $orcish_compare =~ s/\$([ab])/$1 eq 'a' ? 'b' : 'a'/ge |
534
|
|
|
|
|
|
|
# if $key->{descending} ; |
535
|
52
|
100
|
|
|
|
281
|
$orcish_compare =~ s/cmp/<=>/ if $key->{type} eq 'number' ; |
536
|
52
|
50
|
66
|
|
|
439
|
$orcish_compare =~ s/uc //g |
537
|
|
|
|
|
|
|
unless $key->{type} eq 'string' && $key->{no_case} ; |
538
|
|
|
|
|
|
|
|
539
|
52
|
|
|
|
|
366
|
$orcish_compare =~ s/EXTRACT/$key->{code}/g ; |
540
|
|
|
|
|
|
|
|
541
|
52
|
|
|
|
|
198
|
push( @orcish_compares, $orcish_compare ) ; |
542
|
|
|
|
|
|
|
} |
543
|
|
|
|
|
|
|
|
544
|
|
|
|
|
|
|
# build the full compare block |
545
|
|
|
|
|
|
|
|
546
|
47
|
|
|
|
|
139
|
my $compare_source = join "\t\t||\n", @orcish_compares ; |
547
|
|
|
|
|
|
|
|
548
|
|
|
|
|
|
|
# handle the in/out as ref options |
549
|
|
|
|
|
|
|
|
550
|
47
|
100
|
|
|
|
127
|
my $input = $options->{ref_in} ? '@{$_[0]}' : '@_' ; |
551
|
47
|
100
|
|
|
|
176
|
my( $open_bracket, $close_bracket ) = $options->{ref_out} ? |
552
|
|
|
|
|
|
|
qw( [ ] ) : ( '', '' ) ; |
553
|
|
|
|
|
|
|
|
554
|
47
|
|
|
|
|
87
|
my $cache_dcl = join( ',', map "%or_cache$_", 1 .. @{$keys} ) ; |
|
47
|
|
|
|
|
259
|
|
555
|
|
|
|
|
|
|
|
556
|
47
|
|
|
|
|
236
|
my $source = <
|
557
|
|
|
|
|
|
|
sub { |
558
|
|
|
|
|
|
|
$options->{init_code} |
559
|
|
|
|
|
|
|
my ( $cache_dcl ) ; |
560
|
|
|
|
|
|
|
|
561
|
|
|
|
|
|
|
$open_bracket |
562
|
|
|
|
|
|
|
sort { |
563
|
|
|
|
|
|
|
$compare_source |
564
|
|
|
|
|
|
|
} $input $close_bracket ; |
565
|
|
|
|
|
|
|
} |
566
|
|
|
|
|
|
|
SUB |
567
|
|
|
|
|
|
|
|
568
|
47
|
|
|
|
|
145
|
return $source ; |
569
|
|
|
|
|
|
|
} |
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
sub _make_ST_sort { |
572
|
|
|
|
|
|
|
|
573
|
51
|
|
|
51
|
|
82
|
my( $options, $keys ) = @_ ; |
574
|
|
|
|
|
|
|
|
575
|
51
|
|
|
|
|
81
|
my( @st_compares, @st_extracts ) ; |
576
|
51
|
|
|
|
|
82
|
my $st_ind = '1' ; |
577
|
|
|
|
|
|
|
|
578
|
51
|
|
|
|
|
79
|
foreach my $key ( @{$keys} ) { |
|
51
|
|
|
|
|
116
|
|
579
|
|
|
|
|
|
|
|
580
|
|
|
|
|
|
|
#print Dumper $key ; |
581
|
|
|
|
|
|
|
|
582
|
60
|
|
|
|
|
150
|
my $st_compare = <
|
583
|
|
|
|
|
|
|
\$a->[$st_ind] cmp \$b->[$st_ind] |
584
|
|
|
|
|
|
|
CMP |
585
|
|
|
|
|
|
|
|
586
|
60
|
100
|
|
|
|
187
|
$st_compare =~ tr/ab/ba/ if $key->{descending} ; |
587
|
60
|
100
|
|
|
|
242
|
$st_compare =~ s/cmp/<=>/ if $key->{type} eq 'number' ; |
588
|
|
|
|
|
|
|
|
589
|
60
|
|
|
|
|
94
|
$st_ind++ ; |
590
|
|
|
|
|
|
|
|
591
|
60
|
|
|
|
|
135
|
push( @st_compares, $st_compare ) ; |
592
|
|
|
|
|
|
|
|
593
|
60
|
|
|
|
|
120
|
my $st_extract = <
|
594
|
|
|
|
|
|
|
do{ my (\$val) = EXTRACT ; uc \$val } |
595
|
|
|
|
|
|
|
EXT |
596
|
|
|
|
|
|
|
|
597
|
60
|
50
|
66
|
|
|
414
|
$st_extract =~ s/uc // |
598
|
|
|
|
|
|
|
unless $key->{type} eq 'string' && $key->{no_case} ; |
599
|
60
|
|
|
|
|
365
|
$st_extract =~ s/EXTRACT/$key->{code}/ ; |
600
|
|
|
|
|
|
|
|
601
|
60
|
|
|
|
|
152
|
chomp( $st_extract ) ; |
602
|
60
|
|
|
|
|
189
|
push( @st_extracts, $st_extract ) ; |
603
|
|
|
|
|
|
|
} |
604
|
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
# build the full compare block |
606
|
|
|
|
|
|
|
|
607
|
51
|
|
|
|
|
140
|
my $compare_source = join "\t\t||\n", @st_compares ; |
608
|
|
|
|
|
|
|
|
609
|
|
|
|
|
|
|
# build the full code for the key extracts |
610
|
|
|
|
|
|
|
|
611
|
51
|
|
|
|
|
97
|
my $extract_source = join ",\n", @st_extracts ; |
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
# handle the in/out as ref options |
614
|
|
|
|
|
|
|
|
615
|
51
|
100
|
|
|
|
158
|
my $input = $options->{ref_in} ? '@{$_[0]}' : '@_' ; |
616
|
51
|
100
|
|
|
|
168
|
my( $open_bracket, $close_bracket ) = $options->{ref_out} ? |
617
|
|
|
|
|
|
|
qw( [ ] ) : ( '', '' ) ; |
618
|
|
|
|
|
|
|
|
619
|
51
|
|
|
|
|
335
|
my $source = <
|
620
|
|
|
|
|
|
|
sub { |
621
|
|
|
|
|
|
|
$options->{init_code} |
622
|
|
|
|
|
|
|
return $open_bracket |
623
|
|
|
|
|
|
|
map \$_->[0], |
624
|
|
|
|
|
|
|
sort { |
625
|
|
|
|
|
|
|
$compare_source |
626
|
|
|
|
|
|
|
} |
627
|
|
|
|
|
|
|
map [ \$_, |
628
|
|
|
|
|
|
|
$extract_source |
629
|
|
|
|
|
|
|
], $input $close_bracket ; |
630
|
|
|
|
|
|
|
} |
631
|
|
|
|
|
|
|
SUB |
632
|
|
|
|
|
|
|
|
633
|
|
|
|
|
|
|
} |
634
|
|
|
|
|
|
|
|
635
|
|
|
|
|
|
|
sub _make_GRT_sort { |
636
|
|
|
|
|
|
|
|
637
|
87
|
|
|
87
|
|
134
|
my( $options, $keys ) = @_ ; |
638
|
|
|
|
|
|
|
|
639
|
87
|
|
|
|
|
106
|
my( $pack_format, @grt_extracts ) ; |
640
|
|
|
|
|
|
|
|
641
|
87
|
|
|
|
|
151
|
my $init_code = $options->{init_code} ; |
642
|
|
|
|
|
|
|
|
643
|
|
|
|
|
|
|
# select the input as a list - either an array ref or plain @_ |
644
|
|
|
|
|
|
|
|
645
|
87
|
100
|
|
|
|
210
|
my $input = $options->{ref_in} ? '@{$_[0]}' : '@_' ; |
646
|
|
|
|
|
|
|
|
647
|
|
|
|
|
|
|
# use this to count keys so we can generate init_code for each key |
648
|
|
|
|
|
|
|
|
649
|
87
|
|
|
|
|
113
|
my $key_ind = '0' ; |
650
|
|
|
|
|
|
|
|
651
|
87
|
|
|
|
|
103
|
foreach my $key ( @{$keys} ) { |
|
87
|
|
|
|
|
225
|
|
652
|
|
|
|
|
|
|
|
653
|
|
|
|
|
|
|
#print Dumper $key ; |
654
|
|
|
|
|
|
|
|
655
|
100
|
100
|
|
|
|
435
|
my( $key_pack_format, $grt_extract, $key_init_code ) = |
656
|
|
|
|
|
|
|
$key->{type} eq 'number' ? |
657
|
|
|
|
|
|
|
_make_GRT_number_key( $key ) : |
658
|
|
|
|
|
|
|
_make_GRT_string_key( $key, $key_ind++ ) ; |
659
|
|
|
|
|
|
|
|
660
|
|
|
|
|
|
|
#print "[$key_pack_format] [$grt_extract] [$key_init_code]\n" ; |
661
|
|
|
|
|
|
|
|
662
|
100
|
100
|
|
|
|
303
|
return unless $key_pack_format ; |
663
|
|
|
|
|
|
|
|
664
|
99
|
|
|
|
|
127
|
$pack_format .= $key_pack_format ; |
665
|
|
|
|
|
|
|
|
666
|
99
|
100
|
|
|
|
194
|
if ( $key_init_code ) { |
667
|
|
|
|
|
|
|
|
668
|
|
|
|
|
|
|
# fix generated init_code that scans input to use the proper input |
669
|
|
|
|
|
|
|
|
670
|
16
|
|
|
|
|
60
|
$key_init_code =~ s/INPUT$/$input/m ; |
671
|
16
|
|
|
|
|
27
|
$init_code .= $key_init_code ; |
672
|
|
|
|
|
|
|
} |
673
|
|
|
|
|
|
|
|
674
|
99
|
|
|
|
|
170
|
chomp( $grt_extract ) ; |
675
|
99
|
|
|
|
|
262
|
push( @grt_extracts, $grt_extract ) ; |
676
|
|
|
|
|
|
|
} |
677
|
|
|
|
|
|
|
|
678
|
|
|
|
|
|
|
############ |
679
|
|
|
|
|
|
|
# pack the record index. |
680
|
|
|
|
|
|
|
# SKIP for 'string_data' attribute |
681
|
|
|
|
|
|
|
########## |
682
|
|
|
|
|
|
|
|
683
|
86
|
100
|
|
|
|
243
|
$pack_format .= 'N' unless $options->{string_data} ; |
684
|
|
|
|
|
|
|
|
685
|
86
|
|
|
|
|
189
|
my $extract_source = join ",\n", @grt_extracts ; |
686
|
86
|
|
|
|
|
113
|
chomp( $extract_source ) ; |
687
|
|
|
|
|
|
|
|
688
|
|
|
|
|
|
|
# handle the in/out as ref options |
689
|
|
|
|
|
|
|
|
690
|
86
|
100
|
|
|
|
239
|
my( $open_bracket, $close_bracket ) = $options->{ref_out} ? |
691
|
|
|
|
|
|
|
qw( [ ] ) : ( '', '' ) ; |
692
|
|
|
|
|
|
|
|
693
|
|
|
|
|
|
|
|
694
|
86
|
|
|
|
|
174
|
my $get_index_code = <
|
695
|
|
|
|
|
|
|
unpack( 'N', substr( \$_, -$INT_LEN ) ) |
696
|
|
|
|
|
|
|
INDEX |
697
|
86
|
|
|
|
|
110
|
chomp $get_index_code ; |
698
|
|
|
|
|
|
|
|
699
|
86
|
100
|
|
|
|
461
|
my $source = $options->{string_data} ? <
|
700
|
|
|
|
|
|
|
sub { |
701
|
|
|
|
|
|
|
|
702
|
|
|
|
|
|
|
$init_code |
703
|
|
|
|
|
|
|
return $open_bracket |
704
|
|
|
|
|
|
|
map substr( \$_, rindex( \$_, "\0" ) + 1 ), |
705
|
|
|
|
|
|
|
sort |
706
|
|
|
|
|
|
|
map pack( "${pack_format}xa*", |
707
|
|
|
|
|
|
|
$extract_source, |
708
|
|
|
|
|
|
|
\$_ |
709
|
|
|
|
|
|
|
), ${input} |
710
|
|
|
|
|
|
|
$close_bracket; |
711
|
|
|
|
|
|
|
} |
712
|
|
|
|
|
|
|
STRING_DATA |
713
|
|
|
|
|
|
|
sub { |
714
|
|
|
|
|
|
|
my \$rec_ind = 0 ; |
715
|
|
|
|
|
|
|
$init_code |
716
|
|
|
|
|
|
|
return $open_bracket ${input}\[ |
717
|
|
|
|
|
|
|
map $get_index_code, |
718
|
|
|
|
|
|
|
sort |
719
|
|
|
|
|
|
|
map pack( "$pack_format", |
720
|
|
|
|
|
|
|
$extract_source, |
721
|
|
|
|
|
|
|
\$rec_ind++ |
722
|
|
|
|
|
|
|
), ${input} |
723
|
|
|
|
|
|
|
] $close_bracket; |
724
|
|
|
|
|
|
|
} |
725
|
|
|
|
|
|
|
REF_DATA |
726
|
|
|
|
|
|
|
|
727
|
|
|
|
|
|
|
#print $source ; |
728
|
|
|
|
|
|
|
|
729
|
86
|
|
|
|
|
313
|
return $source ; |
730
|
|
|
|
|
|
|
} |
731
|
|
|
|
|
|
|
|
732
|
|
|
|
|
|
|
# code string to pack a float key value. |
733
|
|
|
|
|
|
|
|
734
|
|
|
|
|
|
|
my $FLOAT_PACK = $IS_BIG_ENDIAN ? |
735
|
|
|
|
|
|
|
q{pack( 'd', $val )} : |
736
|
|
|
|
|
|
|
q{reverse( pack( 'd', $val ) )} ; |
737
|
|
|
|
|
|
|
|
738
|
|
|
|
|
|
|
# bit mask to xor a packed float |
739
|
|
|
|
|
|
|
|
740
|
|
|
|
|
|
|
my $XOR_NEG = '\xFF' x $FLOAT_LEN ; |
741
|
|
|
|
|
|
|
|
742
|
|
|
|
|
|
|
sub _make_GRT_number_key { |
743
|
|
|
|
|
|
|
|
744
|
46
|
|
|
46
|
|
70
|
my( $key ) = @_ ; |
745
|
|
|
|
|
|
|
|
746
|
46
|
|
|
|
|
64
|
my( $pack_format, $val_code, $negate_code ) ; |
747
|
|
|
|
|
|
|
|
748
|
46
|
100
|
|
|
|
110
|
if ( $key->{descending} ) { |
749
|
|
|
|
|
|
|
|
750
|
|
|
|
|
|
|
# negate the key values so they sort in descending order |
751
|
|
|
|
|
|
|
|
752
|
12
|
|
|
|
|
26
|
$negate_code = '$val = -$val; ' ; |
753
|
|
|
|
|
|
|
|
754
|
|
|
|
|
|
|
# descending GRT number sorts must be signed to handle the negated values |
755
|
|
|
|
|
|
|
|
756
|
12
|
100
|
|
|
|
45
|
$key->{signed} = 1 if delete $key->{unsigned} ; |
757
|
12
|
100
|
|
|
|
52
|
$key->{signed_float} = 1 if delete $key->{unsigned_float} ; |
758
|
|
|
|
|
|
|
} |
759
|
|
|
|
|
|
|
else { |
760
|
|
|
|
|
|
|
|
761
|
34
|
|
|
|
|
59
|
$negate_code = '' ; |
762
|
|
|
|
|
|
|
} |
763
|
|
|
|
|
|
|
|
764
|
46
|
100
|
|
|
|
230
|
if ( $key->{unsigned} ) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
765
|
|
|
|
|
|
|
|
766
|
3
|
|
|
|
|
5
|
$pack_format = 'N' ; |
767
|
3
|
|
|
|
|
7
|
$val_code = '$val' ; |
768
|
|
|
|
|
|
|
} |
769
|
|
|
|
|
|
|
elsif ( $key->{signed} ) { |
770
|
|
|
|
|
|
|
|
771
|
|
|
|
|
|
|
# convert the signed integer to unsigned by flipping the sign bit |
772
|
|
|
|
|
|
|
|
773
|
9
|
|
|
|
|
14
|
$pack_format = 'N' ; |
774
|
9
|
|
|
|
|
27
|
$val_code = "\$val ^ (1 << ($INT_BIT_LEN - 1))" |
775
|
|
|
|
|
|
|
} |
776
|
|
|
|
|
|
|
elsif ( $key->{unsigned_float} ) { |
777
|
|
|
|
|
|
|
|
778
|
|
|
|
|
|
|
# pack into A format with a length of a float |
779
|
|
|
|
|
|
|
|
780
|
3
|
|
|
|
|
17
|
$pack_format = "A$FLOAT_LEN" ; |
781
|
3
|
|
|
|
|
8
|
$val_code = qq{ $FLOAT_PACK ^ "\\x80" } ; |
782
|
|
|
|
|
|
|
} |
783
|
|
|
|
|
|
|
else { |
784
|
|
|
|
|
|
|
|
785
|
|
|
|
|
|
|
# must be a signed float |
786
|
|
|
|
|
|
|
|
787
|
31
|
|
|
|
|
59
|
$pack_format = "A$FLOAT_LEN" ; |
788
|
|
|
|
|
|
|
|
789
|
|
|
|
|
|
|
# debug code that can be put in to dump what is being packed. |
790
|
|
|
|
|
|
|
# print "V [\$val]\\n" ; |
791
|
|
|
|
|
|
|
# print unpack( 'H*', pack 'd', \$val ), "\\n" ; |
792
|
|
|
|
|
|
|
|
793
|
|
|
|
|
|
|
|
794
|
|
|
|
|
|
|
# only negate float numbers other than 0. in some odd cases a float 0 |
795
|
|
|
|
|
|
|
# gets converted to a -0 (which is a legal ieee float) and the GRT |
796
|
|
|
|
|
|
|
# packs it as 0x80000.. instead of 0x00000....) |
797
|
|
|
|
|
|
|
|
798
|
|
|
|
|
|
|
# it happens on sparc and perl 5.6.1. it needs a math op (the tests |
799
|
|
|
|
|
|
|
# runs the gold sort which does <=> on it) and then negation for -0 to |
800
|
|
|
|
|
|
|
# show up. 5.8 on sparc is fine and all perl versions on intel are |
801
|
|
|
|
|
|
|
# fine |
802
|
|
|
|
|
|
|
|
803
|
|
|
|
|
|
|
# the 'signed float edge case descending' test in t/numbers.t |
804
|
|
|
|
|
|
|
# looks for this. |
805
|
|
|
|
|
|
|
|
806
|
31
|
|
|
|
|
62
|
$negate_code =~ s/;/ if \$val;/ ; |
807
|
|
|
|
|
|
|
|
808
|
31
|
|
|
|
|
103
|
$val_code = qq{ $FLOAT_PACK ^ |
809
|
|
|
|
|
|
|
( \$val < 0 ? "$XOR_NEG" : "\\x80" ) |
810
|
|
|
|
|
|
|
} ; |
811
|
|
|
|
|
|
|
} |
812
|
|
|
|
|
|
|
|
813
|
46
|
|
|
|
|
146
|
my $grt_extract = <
|
814
|
|
|
|
|
|
|
do{ my (\$val) = $key->{code} ; $negate_code$val_code } |
815
|
|
|
|
|
|
|
CODE |
816
|
|
|
|
|
|
|
|
817
|
46
|
|
|
|
|
179
|
return( $pack_format, $grt_extract, '' ) ; |
818
|
|
|
|
|
|
|
} |
819
|
|
|
|
|
|
|
|
820
|
|
|
|
|
|
|
sub _make_GRT_string_key { |
821
|
|
|
|
|
|
|
|
822
|
54
|
|
|
54
|
|
80
|
my( $key, $key_ind ) = @_ ; |
823
|
|
|
|
|
|
|
|
824
|
54
|
|
|
|
|
123
|
my( $init_code, $pack_format ) ; |
825
|
|
|
|
|
|
|
|
826
|
54
|
100
|
|
|
|
204
|
if ( my $fix_len = $key->{fixed} ) { |
|
|
100
|
|
|
|
|
|
827
|
|
|
|
|
|
|
|
828
|
|
|
|
|
|
|
# create the xor string to invert the key for a descending sort. |
829
|
5
|
100
|
|
|
|
17
|
$init_code = <{descending} ; |
830
|
|
|
|
|
|
|
my \$_xor$key_ind = "\\xFF" x $fix_len ; |
831
|
|
|
|
|
|
|
CODE |
832
|
5
|
|
|
|
|
9
|
$pack_format = "a$fix_len" ; |
833
|
|
|
|
|
|
|
|
834
|
|
|
|
|
|
|
} |
835
|
|
|
|
|
|
|
elsif ( $key->{varying} ) { |
836
|
|
|
|
|
|
|
|
837
|
|
|
|
|
|
|
# create the code to scan for the maximum length of the values for this key |
838
|
|
|
|
|
|
|
# the INPUT will be changed later to handle a list or a ref as input |
839
|
|
|
|
|
|
|
|
840
|
13
|
|
|
|
|
39
|
$init_code = <
|
841
|
|
|
|
|
|
|
use List::Util qw( max ) ; |
842
|
|
|
|
|
|
|
my \$len$key_ind = max( |
843
|
|
|
|
|
|
|
map { my (\$val) = $key->{code} ; length \$val } INPUT |
844
|
|
|
|
|
|
|
) ; |
845
|
|
|
|
|
|
|
CODE |
846
|
|
|
|
|
|
|
|
847
|
|
|
|
|
|
|
# create the xor string to invert the key for a descending sort. |
848
|
|
|
|
|
|
|
|
849
|
13
|
100
|
|
|
|
46
|
$init_code .= <{descending} ; |
850
|
|
|
|
|
|
|
my \$_xor$key_ind = "\\xFF" x \$len$key_ind ; |
851
|
|
|
|
|
|
|
CODE |
852
|
|
|
|
|
|
|
|
853
|
|
|
|
|
|
|
# we pack as a null padded string. its length is in the |
854
|
|
|
|
|
|
|
|
855
|
13
|
|
|
|
|
20
|
$pack_format = "a\${len$key_ind}" ; |
856
|
|
|
|
|
|
|
} |
857
|
|
|
|
|
|
|
else { |
858
|
|
|
|
|
|
|
|
859
|
|
|
|
|
|
|
# we can't sort plain (null terminated) strings in descending order |
860
|
|
|
|
|
|
|
|
861
|
36
|
100
|
|
|
|
99
|
$@ = <{descending} ; |
862
|
|
|
|
|
|
|
make_sorter: A GRT descending string needs to select either the |
863
|
|
|
|
|
|
|
'fixed' or 'varying' attributes |
864
|
|
|
|
|
|
|
ERR |
865
|
|
|
|
|
|
|
|
866
|
35
|
|
|
|
|
61
|
$pack_format = 'Z*' ; |
867
|
|
|
|
|
|
|
} |
868
|
|
|
|
|
|
|
|
869
|
53
|
100
|
|
|
|
128
|
my $descend_code = $key->{descending} ? " . '' ^ \$_xor$key_ind" : '' ; |
870
|
|
|
|
|
|
|
|
871
|
53
|
|
|
|
|
124
|
my $grt_extract = <
|
872
|
|
|
|
|
|
|
do{ my( \$val ) = EXTRACT ; uc( \$val )$descend_code } |
873
|
|
|
|
|
|
|
CODE |
874
|
|
|
|
|
|
|
|
875
|
53
|
100
|
|
|
|
245
|
$grt_extract =~ s/uc// unless $key->{no_case} ; |
876
|
53
|
|
|
|
|
279
|
$grt_extract =~ s/EXTRACT/$key->{code}/ ; |
877
|
|
|
|
|
|
|
|
878
|
53
|
|
|
|
|
191
|
return( $pack_format, $grt_extract, $init_code ) ; |
879
|
|
|
|
|
|
|
} |
880
|
|
|
|
|
|
|
|
881
|
|
|
|
|
|
|
sub sorter_source { |
882
|
|
|
|
|
|
|
|
883
|
0
|
|
0
|
0
|
1
|
0
|
$sources{ +shift || '' } ; |
884
|
|
|
|
|
|
|
} |
885
|
|
|
|
|
|
|
|
886
|
|
|
|
|
|
|
1 ; |
887
|
|
|
|
|
|
|
|
888
|
|
|
|
|
|
|
__END__ |