Filename | /usr/local/src/github.com/foswiki/core/lib/CPAN/lib/Sort/Maker.pm |
Statements | Executed 4487 statements in 22.8ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
20 | 1 | 1 | 5.57ms | 17.6ms | make_sorter | Sort::Maker::
80 | 2 | 1 | 3.22ms | 3.22ms | _has_mutex_attrs | Sort::Maker::
20 | 1 | 1 | 2.73ms | 5.96ms | _process_defaults | Sort::Maker::
20 | 1 | 1 | 2.64ms | 3.44ms | _make_ST_sort | Sort::Maker::
20 | 1 | 1 | 1.90ms | 7.85ms | _process_arguments | Sort::Maker::
20 | 1 | 1 | 1.55ms | 1.55ms | CORE:sort (opcode) | Sort::Maker::
20 | 1 | 1 | 690µs | 690µs | _get_extractor_code | Sort::Maker::
180 | 3 | 1 | 530µs | 530µs | CORE:subst (opcode) | Sort::Maker::
120 | 1 | 1 | 273µs | 273µs | CORE:substcont (opcode) | Sort::Maker::
1 | 1 | 1 | 30µs | 127µs | BEGIN@6 | Sort::Maker::
1 | 1 | 1 | 26µs | 35µs | BEGIN@3 | Sort::Maker::
1 | 1 | 1 | 24µs | 211µs | BEGIN@4 | Sort::Maker::
1 | 1 | 1 | 20µs | 61µs | BEGIN@159 | Sort::Maker::
4 | 3 | 1 | 11µs | 11µs | CORE:pack (opcode) | Sort::Maker::
0 | 0 | 0 | 0s | 0s | __ANON__[:139] | Sort::Maker::
0 | 0 | 0 | 0s | 0s | _make_GRT_number_key | Sort::Maker::
0 | 0 | 0 | 0s | 0s | _make_GRT_sort | Sort::Maker::
0 | 0 | 0 | 0s | 0s | _make_GRT_string_key | Sort::Maker::
0 | 0 | 0 | 0s | 0s | _make_orcish_sort | Sort::Maker::
0 | 0 | 0 | 0s | 0s | _make_plain_sort | Sort::Maker::
0 | 0 | 0 | 0s | 0s | _process_array_attrs | Sort::Maker::
0 | 0 | 0 | 0s | 0s | sorter_source | Sort::Maker::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package Sort::Maker; | ||||
2 | |||||
3 | 2 | 53µs | 2 | 43µs | # spent 35µs (26+8) within Sort::Maker::BEGIN@3 which was called:
# once (26µs+8µs) by Foswiki::Templates::BEGIN@483 at line 3 # spent 35µs making 1 call to Sort::Maker::BEGIN@3
# spent 8µs making 1 call to strict::import |
4 | 2 | 62µs | 2 | 399µs | # spent 211µs (24+187) within Sort::Maker::BEGIN@4 which was called:
# once (24µs+187µs) by Foswiki::Templates::BEGIN@483 at line 4 # spent 211µs making 1 call to Sort::Maker::BEGIN@4
# spent 187µs making 1 call to base::import |
5 | |||||
6 | 2 | 926µs | 2 | 224µs | # spent 127µs (30+97) within Sort::Maker::BEGIN@6 which was called:
# once (30µs+97µs) by Foswiki::Templates::BEGIN@483 at line 6 # spent 127µs making 1 call to Sort::Maker::BEGIN@6
# spent 97µs making 1 call to Exporter::import |
7 | |||||
8 | 1 | 3µs | our @EXPORT = qw( make_sorter ); | ||
9 | 1 | 5µs | our %EXPORT_TAGS = ( 'all' => [ qw( sorter_source ), @EXPORT ] ); | ||
10 | 2 | 6µs | our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); | ||
11 | |||||
12 | 1 | 2µs | our $VERSION = '0.06'; | ||
13 | |||||
14 | |||||
15 | # get integer and float sizes endian order | ||||
16 | |||||
17 | 1 | 16µs | 1 | 5µs | my $FLOAT_LEN = length pack "d", 1 ; # spent 5µs making 1 call to Sort::Maker::CORE:pack |
18 | 1 | 8µs | 1 | 2µs | my $INT_LEN = length pack "N", 1 ; # spent 2µs making 1 call to Sort::Maker::CORE:pack |
19 | 1 | 2µs | my $INT_BIT_LEN = $INT_LEN * 8 ; | ||
20 | 1 | 12µs | 2 | 4µs | my $IS_BIG_ENDIAN = pack('N', 1) eq pack('L', 1) ; # spent 4µs making 2 calls to Sort::Maker::CORE:pack, avg 2µs/call |
21 | |||||
22 | 1 | 4µs | 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 | 1 | 2µs | my @value_attrs = qw( | ||
36 | fixed | ||||
37 | ) ; | ||||
38 | |||||
39 | 1 | 4µs | my @grt_num_attrs = qw( | ||
40 | signed | ||||
41 | unsigned | ||||
42 | signed_float | ||||
43 | unsigned_float | ||||
44 | ) ; | ||||
45 | |||||
46 | 1 | 2µs | 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 | 1 | 4µs | 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 | 11 | 36µs | my %is_boolean_attr = map { $_ => 1 } @boolean_attrs ; | ||
65 | 3 | 9µs | my %is_value_attr = map { $_ => 1 } @value_attrs, 'code' ; | ||
66 | |||||
67 | 1 | 2µs | my @boolean_args = qw( | ||
68 | ref_in | ||||
69 | ref_out | ||||
70 | string_data | ||||
71 | ) ; | ||||
72 | |||||
73 | 1 | 2µs | my @value_args = qw( | ||
74 | name | ||||
75 | init_code | ||||
76 | ) ; | ||||
77 | |||||
78 | # all the attributes can be set with defaults | ||||
79 | |||||
80 | 14 | 43µs | my %is_boolean_arg = map { $_ => 1 } @boolean_args, @boolean_attrs ; | ||
81 | 4 | 11µs | my %is_value_arg = map { $_ => 1 } @value_args, @value_attrs ; | ||
82 | |||||
83 | 1 | 2µs | my @key_types = qw( | ||
84 | string | ||||
85 | number | ||||
86 | ) ; | ||||
87 | |||||
88 | 3 | 12µs | my %is_key_arg = map { $_ => 1 } @key_types ; | ||
89 | |||||
90 | 1 | 4µs | 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 | 1 | 14µs | my %is_arg = ( %is_key_arg, %sort_makers, %is_value_arg, %is_boolean_arg ) ; | ||
99 | |||||
100 | 1 | 1µs | my %sources ; | ||
101 | |||||
102 | # this is a file lexical so the WARN handler sub can see it. | ||||
103 | |||||
104 | 1 | 2µs | my $eval_warnings = '' ; | ||
105 | |||||
106 | # spent 17.6ms (5.57+12.0) within Sort::Maker::make_sorter which was called 20 times, avg 878µs/call:
# 20 times (5.57ms+12.0ms) by Foswiki::Templates::_readTemplateFile at line 484 of /usr/local/src/github.com/foswiki/core/lib/Foswiki/Templates.pm, avg 878µs/call | ||||
107 | |||||
108 | # clear any leftover errors | ||||
109 | |||||
110 | 20 | 39µs | $@ = '' ; | ||
111 | |||||
112 | # process @_ without copying it (&sub with no args) | ||||
113 | |||||
114 | 20 | 108µs | 20 | 7.85ms | my( $options, $keys, $closures ) = &_process_arguments ; # spent 7.85ms making 20 calls to Sort::Maker::_process_arguments, avg 393µs/call |
115 | 20 | 26µs | return unless $keys ; | ||
116 | |||||
117 | 20 | 123µs | 20 | 690µs | my @closures = _get_extractor_code( $options, $keys ) ; # spent 690µs making 20 calls to Sort::Maker::_get_extractor_code, avg 35µs/call |
118 | |||||
119 | 20 | 25µs | return if $@ ; | ||
120 | |||||
121 | # get the sort maker for this style and build the sorter | ||||
122 | |||||
123 | 20 | 46µs | my $sort_maker = $sort_makers{ $options->{style} } ; | ||
124 | 20 | 129µs | 20 | 3.44ms | my $source = $sort_maker->( $options, $keys ) ; # spent 3.44ms making 20 calls to Sort::Maker::_make_ST_sort, avg 172µs/call |
125 | 20 | 25µs | return unless $source ; | ||
126 | |||||
127 | # prepend code to access any closures | ||||
128 | |||||
129 | 20 | 31µs | if ( @closures ) { | ||
130 | |||||
131 | my $closure_text = join '', map <<CLOSURE, 0 .. $#closures ; | ||||
132 | my \$closure$_ = \$closures[$_] ; | ||||
133 | CLOSURE | ||||
134 | |||||
135 | $source = "use strict ;\n$closure_text\n$source" ; | ||||
136 | } | ||||
137 | |||||
138 | 20 | 62µs | my $sorter = do { | ||
139 | 20 | 205µs | local( $SIG{__WARN__} ) = sub { $eval_warnings .= $_[0] } ; | ||
140 | 20 | 4.13ms | eval $source ; # spent 6.19ms executing statements in 20 string evals (merged) # includes 4.39ms spent executing 20 calls to 1 sub defined therein. | ||
141 | } ; | ||||
142 | |||||
143 | 20 | 84µs | $sources{ $sorter || '' } = $source ; | ||
144 | |||||
145 | 20 | 25µs | $@ = <<ERR, return unless $sorter ; | ||
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 | 20 | 41µs | if ( my $name = $options->{name} ) { | ||
158 | |||||
159 | 2 | 4.10ms | 2 | 102µs | # spent 61µs (20+41) within Sort::Maker::BEGIN@159 which was called:
# once (20µs+41µs) by Foswiki::Templates::BEGIN@483 at line 159 # spent 61µs making 1 call to Sort::Maker::BEGIN@159
# spent 41µs making 1 call to strict::unimport |
160 | |||||
161 | my $package = (caller())[0] ; | ||||
162 | |||||
163 | *{"${package}::$name"} = $sorter ; | ||||
164 | } | ||||
165 | |||||
166 | 20 | 242µs | return $sorter ; | ||
167 | } | ||||
168 | |||||
169 | # spent 7.85ms (1.90+5.96) within Sort::Maker::_process_arguments which was called 20 times, avg 393µs/call:
# 20 times (1.90ms+5.96ms) by Sort::Maker::make_sorter at line 114, avg 393µs/call | ||||
170 | |||||
171 | 20 | 35µs | my( %options, @keys ) ; | ||
172 | |||||
173 | 20 | 169µs | while( @_ ) { | ||
174 | |||||
175 | 80 | 121µs | my $opt = shift ; | ||
176 | |||||
177 | 80 | 124µs | if ( $sort_makers{ $opt } ) { | ||
178 | |||||
179 | $@ = | ||||
180 | "make_sorter: Style was already set to '$options{ style }'", | ||||
181 | 20 | 32µs | return if $options{ style } ; | ||
182 | |||||
183 | # handle optional boolean => 1 | ||||
184 | 20 | 38µs | shift if @_ && $_[0] eq '1' ; | ||
185 | 20 | 58µs | $options{ style } = $opt ; | ||
186 | 20 | 36µs | $options{ $opt } = 1 ; | ||
187 | |||||
188 | 20 | 35µs | next ; | ||
189 | } | ||||
190 | |||||
191 | 60 | 80µs | if ( $is_boolean_arg{ $opt } ) { | ||
192 | |||||
193 | # handle optional boolean => 1 | ||||
194 | shift if @_ && $_[0] eq '1' ; | ||||
195 | $options{ $opt } = 1 ; | ||||
196 | next ; | ||||
197 | } | ||||
198 | |||||
199 | 60 | 77µs | if ( $is_value_arg{ $opt } ) { | ||
200 | |||||
201 | $@ = "make_sorter: No value for argument '$opt'\n", | ||||
202 | return unless @_ ; | ||||
203 | |||||
204 | $options{ $opt } = shift ; | ||||
205 | next ; | ||||
206 | } | ||||
207 | |||||
208 | 60 | 91µs | if ( $is_key_arg{ $opt } ) { | ||
209 | |||||
210 | 60 | 82µs | 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 | 60 | 102µs | if ( !defined( $key_desc ) || $is_arg{ $key_desc } ) { | ||
215 | |||||
216 | push( @keys, { | ||||
217 | type => $opt, | ||||
218 | } | ||||
219 | ) ; | ||||
220 | |||||
221 | next ; | ||||
222 | } | ||||
223 | |||||
224 | # if we have a hash ref for the value, it is the description for this key | ||||
225 | |||||
226 | 60 | 82µs | if( ref $key_desc eq 'HASH' ) { | ||
227 | |||||
228 | shift @_ ; | ||||
229 | $key_desc->{type} = $opt ; | ||||
230 | push( @keys, $key_desc ) ; | ||||
231 | next ; | ||||
232 | } | ||||
233 | |||||
234 | # if we have an array ref for the value, it is the description for this key | ||||
235 | |||||
236 | 60 | 77µs | if( ref $key_desc eq 'ARRAY' ) { | ||
237 | |||||
238 | $key_desc = _process_array_attrs(@{$key_desc}) ; | ||||
239 | return unless $key_desc ; | ||||
240 | |||||
241 | shift @_ ; | ||||
242 | $key_desc->{type} = $opt ; | ||||
243 | push( @keys, $key_desc ) ; | ||||
244 | next ; | ||||
245 | } | ||||
246 | |||||
247 | # not a hash ref or an option/key so it must be code for the key | ||||
248 | |||||
249 | 60 | 76µs | shift ; | ||
250 | 60 | 194µs | push( @keys, { | ||
251 | type => $opt, | ||||
252 | code => $key_desc, | ||||
253 | } | ||||
254 | ) ; | ||||
255 | 60 | 86µs | next ; | ||
256 | } | ||||
257 | |||||
258 | $@ = "make_sorter: Unknown option or key '$opt'\n" ; | ||||
259 | return ; | ||||
260 | } | ||||
261 | |||||
262 | 20 | 29µs | unless( @keys ) { | ||
263 | $@ = 'make_sorter: No keys specified' ; | ||||
264 | return ; | ||||
265 | } | ||||
266 | |||||
267 | 20 | 31µs | unless( $options{style} ) { | ||
268 | $@ = 'make_sorter: No sort style selected' ; | ||||
269 | return ; | ||||
270 | } | ||||
271 | |||||
272 | 20 | 126µs | 20 | 5.96ms | return unless _process_defaults( \%options, \@keys ) ; # spent 5.96ms making 20 calls to Sort::Maker::_process_defaults, avg 298µs/call |
273 | |||||
274 | 20 | 118µs | return( \%options, \@keys ) ; | ||
275 | } | ||||
276 | |||||
277 | # spent 5.96ms (2.73+3.22) within Sort::Maker::_process_defaults which was called 20 times, avg 298µs/call:
# 20 times (2.73ms+3.22ms) by Sort::Maker::_process_arguments at line 272, avg 298µs/call | ||||
278 | |||||
279 | 20 | 40µs | my( $opts, $keys ) = @_ ; | ||
280 | |||||
281 | 20 | 108µs | 20 | 884µs | return if _has_mutex_attrs( $opts, 'defaults have' ) ; # spent 884µs making 20 calls to Sort::Maker::_has_mutex_attrs, avg 44µs/call |
282 | |||||
283 | 20 | 58µs | $opts->{init_code} ||= '' ; | ||
284 | |||||
285 | 40 | 122µs | foreach my $key ( @{$keys} ) { | ||
286 | |||||
287 | 60 | 299µs | 60 | 2.34ms | return if _has_mutex_attrs( $key, 'key has' ) ; # spent 2.34ms making 60 calls to Sort::Maker::_has_mutex_attrs, avg 39µs/call |
288 | |||||
289 | # set descending if it is not ascending and the default is descending. | ||||
290 | |||||
291 | 60 | 140µs | $key->{'descending'} ||= | ||
292 | !$key->{'ascending'} && $opts->{'descending'} ; | ||||
293 | |||||
294 | # set no_case if it is not case and the default is no_case. | ||||
295 | |||||
296 | 60 | 104µs | $key->{'no_case'} ||= | ||
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 | 60 | 302µs | unless( grep( $key->{$_}, @grt_num_attrs ) ) { | ||
303 | |||||
304 | 180 | 578µs | @{$key}{@grt_num_attrs} = @{$opts}{@grt_num_attrs} ; | ||
305 | } | ||||
306 | |||||
307 | 60 | 309µs | unless( grep( $key->{$_}, @grt_string_attrs ) ) { | ||
308 | |||||
309 | 120 | 151µs | @{$key}{@grt_string_attrs} = | ||
310 | 60 | 295µs | @{$opts}{@grt_string_attrs} ; | ||
311 | } | ||||
312 | } | ||||
313 | |||||
314 | 20 | 116µs | return 1 ; | ||
315 | } | ||||
316 | |||||
317 | |||||
318 | # spent 690µs within Sort::Maker::_get_extractor_code which was called 20 times, avg 35µs/call:
# 20 times (690µs+0s) by Sort::Maker::make_sorter at line 117, avg 35µs/call | ||||
319 | |||||
320 | 20 | 34µs | my( $opts, $keys ) = @_ ; | ||
321 | |||||
322 | 20 | 28µs | my( @closures, $deparser ) ; | ||
323 | |||||
324 | 40 | 212µs | foreach my $key ( @{$keys} ) { | ||
325 | |||||
326 | 60 | 95µs | my $extract_code = $key->{code} ; | ||
327 | |||||
328 | # default extract code is $_ | ||||
329 | |||||
330 | 60 | 66µs | unless( $extract_code ) { | ||
331 | |||||
332 | $key->{code} = '$_' ; | ||||
333 | next ; | ||||
334 | } | ||||
335 | |||||
336 | 60 | 84µs | my $extractor_type = ref $extract_code ; | ||
337 | |||||
338 | # leave the extractor code alone if it is a string | ||||
339 | |||||
340 | 60 | 80µs | next unless $extractor_type ; | ||
341 | |||||
342 | # wrap regexes in m() | ||||
343 | |||||
344 | if( $extractor_type eq 'Regexp' ) { | ||||
345 | |||||
346 | $key->{code} = "m($extract_code)" ; | ||||
347 | next ; | ||||
348 | } | ||||
349 | |||||
350 | # return an error if it is not a CODE ref | ||||
351 | |||||
352 | unless( $extractor_type eq 'CODE' ) { | ||||
353 | |||||
354 | $@ = "$extract_code is not a CODE or Regexp reference" ; | ||||
355 | return ; | ||||
356 | } | ||||
357 | |||||
358 | # must be a code reference | ||||
359 | # see if it is a closure | ||||
360 | |||||
361 | if ( $opts->{closure} || $key->{closure} ) { | ||||
362 | |||||
363 | # generate the code that will call this closure | ||||
364 | |||||
365 | my $n = @closures ; | ||||
366 | $key->{code} = "\$closure$n->()" ; | ||||
367 | |||||
368 | #print "CODE $key->{code}\n" ; | ||||
369 | |||||
370 | # copy the closure so we can process them later | ||||
371 | |||||
372 | push @closures, $extract_code ; | ||||
373 | next ; | ||||
374 | } | ||||
375 | |||||
376 | # Otherwise, try to decompile the code ref with B::Deparse... | ||||
377 | |||||
378 | unless( require B::Deparse ) { | ||||
379 | |||||
380 | $@ = <<ERR ; | ||||
381 | Can't use CODE as key extractor unless B::Deparse module installed | ||||
382 | ERR | ||||
383 | return ; | ||||
384 | } | ||||
385 | |||||
386 | $deparser ||= B::Deparse->new("-p", "-sC"); | ||||
387 | |||||
388 | my $source = eval { $deparser->coderef2text( $extract_code ) } ; | ||||
389 | |||||
390 | unless( $source ) { | ||||
391 | |||||
392 | $@ = "Can't use [$extract_code] as key extractor"; | ||||
393 | return ; | ||||
394 | } | ||||
395 | |||||
396 | #print "S [$source]\n" ; | ||||
397 | |||||
398 | # use just the juicy pulp inside the braces... | ||||
399 | |||||
400 | $key->{code} = "do $source" ; | ||||
401 | } | ||||
402 | |||||
403 | 20 | 113µs | 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 | 80 | 133µs | my( $href, $name ) = @_ ; | ||
413 | |||||
414 | 80 | 700µs | foreach my $mutex ( @mutex_attrs ) { | ||
415 | |||||
416 | 640 | 1.60ms | my @bad_attrs = grep $href->{$_}, @{$mutex} ; | ||
417 | |||||
418 | 320 | 476µs | next if @bad_attrs <= 1 ; | ||
419 | |||||
420 | $@ = "make_sorter: Key attribute conflict: '$name @bad_attrs'"; | ||||
421 | return 1 ; | ||||
422 | } | ||||
423 | |||||
424 | 80 | 447µs | return ; | ||
425 | } | ||||
426 | |||||
427 | sub _process_array_attrs { | ||||
428 | |||||
429 | my( @attrs ) = @_ ; | ||||
430 | |||||
431 | my $desc ; | ||||
432 | |||||
433 | while( @attrs ) { | ||||
434 | |||||
435 | my $attr = shift @attrs ; | ||||
436 | |||||
437 | #print "ATTR $attr\n" ; | ||||
438 | |||||
439 | if ( $is_boolean_attr{ $attr } ) { | ||||
440 | |||||
441 | shift @attrs if $attrs[0] eq '1' ; | ||||
442 | $desc->{ $attr } = 1 ; | ||||
443 | next ; | ||||
444 | } | ||||
445 | |||||
446 | if ( $is_value_attr{ $attr } ) { | ||||
447 | |||||
448 | $@ = "make_sorter: No value for attribute '$attr'", | ||||
449 | return unless @attrs ; | ||||
450 | |||||
451 | $desc->{ $attr } = shift @attrs ; | ||||
452 | next ; | ||||
453 | } | ||||
454 | |||||
455 | $@ = "make_sorter: Unknown attribute '$attr'" ; | ||||
456 | return ; | ||||
457 | } | ||||
458 | |||||
459 | return( $desc ) ; | ||||
460 | } | ||||
461 | |||||
462 | sub _make_plain_sort { | ||||
463 | |||||
464 | my( $options, $keys ) = @_ ; | ||||
465 | |||||
466 | my( @plain_compares ) ; | ||||
467 | |||||
468 | foreach my $key ( @{$keys} ) { | ||||
469 | |||||
470 | my $plain_compare = <<CMP ; | ||||
471 | do{ my( \$left, \$right ) = map { EXTRACT } \$a, \$b; | ||||
472 | uc \$left cmp uc \$right } | ||||
473 | CMP | ||||
474 | |||||
475 | $plain_compare =~ s/\$a, \$b/\$b, \$a/ if $key->{descending} ; | ||||
476 | $plain_compare =~ s/cmp/<=>/ if $key->{type} eq 'number' ; | ||||
477 | $plain_compare =~ s/uc //g | ||||
478 | unless $key->{type} eq 'string' && $key->{no_case} ; | ||||
479 | $plain_compare =~ s/EXTRACT/$key->{code}/ ; | ||||
480 | |||||
481 | push( @plain_compares, $plain_compare ) ; | ||||
482 | } | ||||
483 | |||||
484 | # build the full compare block | ||||
485 | |||||
486 | my $compare_source = join "\t\t||\n", @plain_compares ; | ||||
487 | |||||
488 | # handle the in/out as ref options | ||||
489 | |||||
490 | my $input = $options->{ref_in} ? '@{$_[0]}' : '@_' ; | ||||
491 | my( $open_bracket, $close_bracket ) = $options->{ref_out} ? | ||||
492 | qw( [ ] ) : ( '', '' ) ; | ||||
493 | |||||
494 | my $source = <<SUB ; | ||||
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 | return $source ; | ||||
507 | } | ||||
508 | |||||
509 | sub _make_orcish_sort { | ||||
510 | |||||
511 | my( $options, $keys ) = @_ ; | ||||
512 | |||||
513 | my( @orcish_compares ) ; | ||||
514 | |||||
515 | my $orc_ind = '1' ; | ||||
516 | |||||
517 | foreach my $key ( @{$keys} ) { | ||||
518 | |||||
519 | my( $l, $r ) = $key->{descending} ? qw( $b $a ) : qw( $a $b ) ; | ||||
520 | |||||
521 | my $orcish_compare = <<CMP ; | ||||
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 | $orc_ind++ ; | ||||
532 | |||||
533 | # $orcish_compare =~ s/\$([ab])/$1 eq 'a' ? 'b' : 'a'/ge | ||||
534 | # if $key->{descending} ; | ||||
535 | $orcish_compare =~ s/cmp/<=>/ if $key->{type} eq 'number' ; | ||||
536 | $orcish_compare =~ s/uc //g | ||||
537 | unless $key->{type} eq 'string' && $key->{no_case} ; | ||||
538 | |||||
539 | $orcish_compare =~ s/EXTRACT/$key->{code}/g ; | ||||
540 | |||||
541 | push( @orcish_compares, $orcish_compare ) ; | ||||
542 | } | ||||
543 | |||||
544 | # build the full compare block | ||||
545 | |||||
546 | my $compare_source = join "\t\t||\n", @orcish_compares ; | ||||
547 | |||||
548 | # handle the in/out as ref options | ||||
549 | |||||
550 | my $input = $options->{ref_in} ? '@{$_[0]}' : '@_' ; | ||||
551 | my( $open_bracket, $close_bracket ) = $options->{ref_out} ? | ||||
552 | qw( [ ] ) : ( '', '' ) ; | ||||
553 | |||||
554 | my $cache_dcl = join( ',', map "%or_cache$_", 1 .. @{$keys} ) ; | ||||
555 | |||||
556 | my $source = <<SUB ; | ||||
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 | return $source ; | ||||
569 | } | ||||
570 | |||||
571 | # spent 3.44ms (2.64+803µs) within Sort::Maker::_make_ST_sort which was called 20 times, avg 172µs/call:
# 20 times (2.64ms+803µs) by Sort::Maker::make_sorter at line 124, avg 172µs/call | ||||
572 | |||||
573 | 20 | 34µs | my( $options, $keys ) = @_ ; | ||
574 | |||||
575 | 20 | 28µs | my( @st_compares, @st_extracts ) ; | ||
576 | 20 | 28µs | my $st_ind = '1' ; | ||
577 | |||||
578 | 40 | 130µs | foreach my $key ( @{$keys} ) { | ||
579 | |||||
580 | #print Dumper $key ; | ||||
581 | |||||
582 | 60 | 126µs | my $st_compare = <<CMP ; | ||
583 | \$a->[$st_ind] cmp \$b->[$st_ind] | ||||
584 | CMP | ||||
585 | |||||
586 | 60 | 100µs | $st_compare =~ tr/ab/ba/ if $key->{descending} ; | ||
587 | 60 | 500µs | 60 | 200µs | $st_compare =~ s/cmp/<=>/ if $key->{type} eq 'number' ; # spent 200µs making 60 calls to Sort::Maker::CORE:subst, avg 3µs/call |
588 | |||||
589 | 60 | 78µs | $st_ind++ ; | ||
590 | |||||
591 | 60 | 126µs | push( @st_compares, $st_compare ) ; | ||
592 | |||||
593 | 60 | 84µs | my $st_extract = <<EXT ; | ||
594 | do{ my (\$val) = EXTRACT ; uc \$val } | ||||
595 | EXT | ||||
596 | |||||
597 | 60 | 450µs | 60 | 162µs | $st_extract =~ s/uc // # spent 162µs making 60 calls to Sort::Maker::CORE:subst, avg 3µs/call |
598 | unless $key->{type} eq 'string' && $key->{no_case} ; | ||||
599 | 60 | 1.05ms | 180 | 441µs | $st_extract =~ s/EXTRACT/$key->{code}/ ; # spent 273µs making 120 calls to Sort::Maker::CORE:substcont, avg 2µs/call
# spent 168µs making 60 calls to Sort::Maker::CORE:subst, avg 3µs/call |
600 | |||||
601 | 60 | 106µs | chomp( $st_extract ) ; | ||
602 | 60 | 250µs | push( @st_extracts, $st_extract ) ; | ||
603 | } | ||||
604 | |||||
605 | # build the full compare block | ||||
606 | |||||
607 | 20 | 66µs | my $compare_source = join "\t\t||\n", @st_compares ; | ||
608 | |||||
609 | # build the full code for the key extracts | ||||
610 | |||||
611 | 20 | 39µs | my $extract_source = join ",\n", @st_extracts ; | ||
612 | |||||
613 | # handle the in/out as ref options | ||||
614 | |||||
615 | 20 | 42µs | my $input = $options->{ref_in} ? '@{$_[0]}' : '@_' ; | ||
616 | 20 | 40µs | my( $open_bracket, $close_bracket ) = $options->{ref_out} ? | ||
617 | qw( [ ] ) : ( '', '' ) ; | ||||
618 | |||||
619 | 20 | 180µs | my $source = <<SUB ; | ||
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 | my( $options, $keys ) = @_ ; | ||||
638 | |||||
639 | my( $pack_format, @grt_extracts ) ; | ||||
640 | |||||
641 | my $init_code = $options->{init_code} ; | ||||
642 | |||||
643 | # select the input as a list - either an array ref or plain @_ | ||||
644 | |||||
645 | my $input = $options->{ref_in} ? '@{$_[0]}' : '@_' ; | ||||
646 | |||||
647 | # use this to count keys so we can generate init_code for each key | ||||
648 | |||||
649 | my $key_ind = '0' ; | ||||
650 | |||||
651 | foreach my $key ( @{$keys} ) { | ||||
652 | |||||
653 | #print Dumper $key ; | ||||
654 | |||||
655 | 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 | return unless $key_pack_format ; | ||||
663 | |||||
664 | $pack_format .= $key_pack_format ; | ||||
665 | |||||
666 | if ( $key_init_code ) { | ||||
667 | |||||
668 | # fix generated init_code that scans input to use the proper input | ||||
669 | |||||
670 | $key_init_code =~ s/INPUT$/$input/m ; | ||||
671 | $init_code .= $key_init_code ; | ||||
672 | } | ||||
673 | |||||
674 | chomp( $grt_extract ) ; | ||||
675 | push( @grt_extracts, $grt_extract ) ; | ||||
676 | } | ||||
677 | |||||
678 | ############ | ||||
679 | # pack the record index. | ||||
680 | # SKIP for 'string_data' attribute | ||||
681 | ########## | ||||
682 | |||||
683 | $pack_format .= 'N' unless $options->{string_data} ; | ||||
684 | |||||
685 | my $extract_source = join ",\n", @grt_extracts ; | ||||
686 | chomp( $extract_source ) ; | ||||
687 | |||||
688 | # handle the in/out as ref options | ||||
689 | |||||
690 | my( $open_bracket, $close_bracket ) = $options->{ref_out} ? | ||||
691 | qw( [ ] ) : ( '', '' ) ; | ||||
692 | |||||
693 | |||||
694 | my $get_index_code = <<INDEX ; | ||||
695 | unpack( 'N', substr( \$_, -$INT_LEN ) ) | ||||
696 | INDEX | ||||
697 | chomp $get_index_code ; | ||||
698 | |||||
699 | my $source = $options->{string_data} ? <<STRING_DATA : <<REF_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 | return $source ; | ||||
730 | } | ||||
731 | |||||
732 | # code string to pack a float key value. | ||||
733 | |||||
734 | 1 | 2µs | 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 | 1 | 3µs | my $XOR_NEG = '\xFF' x $FLOAT_LEN ; | ||
741 | |||||
742 | sub _make_GRT_number_key { | ||||
743 | |||||
744 | my( $key ) = @_ ; | ||||
745 | |||||
746 | my( $pack_format, $val_code, $negate_code ) ; | ||||
747 | |||||
748 | if ( $key->{descending} ) { | ||||
749 | |||||
750 | # negate the key values so they sort in descending order | ||||
751 | |||||
752 | $negate_code = '$val = -$val; ' ; | ||||
753 | |||||
754 | # descending GRT number sorts must be signed to handle the negated values | ||||
755 | |||||
756 | $key->{signed} = 1 if delete $key->{unsigned} ; | ||||
757 | $key->{signed_float} = 1 if delete $key->{unsigned_float} ; | ||||
758 | } | ||||
759 | else { | ||||
760 | |||||
761 | $negate_code = '' ; | ||||
762 | } | ||||
763 | |||||
764 | if ( $key->{unsigned} ) { | ||||
765 | |||||
766 | $pack_format = 'N' ; | ||||
767 | $val_code = '$val' ; | ||||
768 | } | ||||
769 | elsif ( $key->{signed} ) { | ||||
770 | |||||
771 | # convert the signed integer to unsigned by flipping the sign bit | ||||
772 | |||||
773 | $pack_format = 'N' ; | ||||
774 | $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 | $pack_format = "A$FLOAT_LEN" ; | ||||
781 | $val_code = qq{ $FLOAT_PACK ^ "\\x80" } ; | ||||
782 | } | ||||
783 | else { | ||||
784 | |||||
785 | # must be a signed float | ||||
786 | |||||
787 | $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 | $negate_code =~ s/;/ if \$val;/ ; | ||||
807 | |||||
808 | $val_code = qq{ $FLOAT_PACK ^ | ||||
809 | ( \$val < 0 ? "$XOR_NEG" : "\\x80" ) | ||||
810 | } ; | ||||
811 | } | ||||
812 | |||||
813 | my $grt_extract = <<CODE ; | ||||
814 | do{ my (\$val) = $key->{code} ; $negate_code$val_code } | ||||
815 | CODE | ||||
816 | |||||
817 | return( $pack_format, $grt_extract, '' ) ; | ||||
818 | } | ||||
819 | |||||
820 | sub _make_GRT_string_key { | ||||
821 | |||||
822 | my( $key, $key_ind ) = @_ ; | ||||
823 | |||||
824 | my( $init_code, $pack_format ) ; | ||||
825 | |||||
826 | if ( my $fix_len = $key->{fixed} ) { | ||||
827 | |||||
828 | # create the xor string to invert the key for a descending sort. | ||||
829 | $init_code = <<CODE if $key->{descending} ; | ||||
830 | my \$_xor$key_ind = "\\xFF" x $fix_len ; | ||||
831 | CODE | ||||
832 | $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 | $init_code = <<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 | $init_code .= <<CODE if $key->{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 | $pack_format = "a\${len$key_ind}" ; | ||||
856 | } | ||||
857 | else { | ||||
858 | |||||
859 | # we can't sort plain (null terminated) strings in descending order | ||||
860 | |||||
861 | $@ = <<ERR, return if $key->{descending} ; | ||||
862 | make_sorter: A GRT descending string needs to select either the | ||||
863 | 'fixed' or 'varying' attributes | ||||
864 | ERR | ||||
865 | |||||
866 | $pack_format = 'Z*' ; | ||||
867 | } | ||||
868 | |||||
869 | my $descend_code = $key->{descending} ? " . '' ^ \$_xor$key_ind" : '' ; | ||||
870 | |||||
871 | my $grt_extract = <<CODE ; | ||||
872 | do{ my( \$val ) = EXTRACT ; uc( \$val )$descend_code } | ||||
873 | CODE | ||||
874 | |||||
875 | $grt_extract =~ s/uc// unless $key->{no_case} ; | ||||
876 | $grt_extract =~ s/EXTRACT/$key->{code}/ ; | ||||
877 | |||||
878 | return( $pack_format, $grt_extract, $init_code ) ; | ||||
879 | } | ||||
880 | |||||
881 | sub sorter_source { | ||||
882 | |||||
883 | $sources{ +shift || '' } ; | ||||
884 | } | ||||
885 | |||||
886 | 1 | 41µs | 1 ; | ||
887 | |||||
888 | __END__ | ||||
sub Sort::Maker::CORE:pack; # opcode | |||||
# spent 1.55ms within Sort::Maker::CORE:sort which was called 20 times, avg 78µs/call:
# 20 times (1.55ms+0s) by Sort::Maker::__ANON__[(eval 136)[/usr/local/src/github.com/foswiki/core/lib/CPAN/lib/Sort/Maker.pm:140]:18] or Sort::Maker::__ANON__[(eval 137)[/usr/local/src/github.com/foswiki/core/lib/CPAN/lib/Sort/Maker.pm:140]:18] or Sort::Maker::__ANON__[(eval 138)[/usr/local/src/github.com/foswiki/core/lib/CPAN/lib/Sort/Maker.pm:140]:18] or Sort::Maker::__ANON__[(eval 139)[/usr/local/src/github.com/foswiki/core/lib/CPAN/lib/Sort/Maker.pm:140]:18] or Sort::Maker::__ANON__[(eval 140)[/usr/local/src/github.com/foswiki/core/lib/CPAN/lib/Sort/Maker.pm:140]:18] or Sort::Maker::__ANON__[(eval 141)[/usr/local/src/github.com/foswiki/core/lib/CPAN/lib/Sort/Maker.pm:140]:18] or Sort::Maker::__ANON__[(eval 142)[/usr/local/src/github.com/foswiki/core/lib/CPAN/lib/Sort/Maker.pm:140]:18] or Sort::Maker::__ANON__[(eval 143)[/usr/local/src/github.com/foswiki/core/lib/CPAN/lib/Sort/Maker.pm:140]:18] or Sort::Maker::__ANON__[(eval 144)[/usr/local/src/github.com/foswiki/core/lib/CPAN/lib/Sort/Maker.pm:140]:18] or Sort::Maker::__ANON__[(eval 145)[/usr/local/src/github.com/foswiki/core/lib/CPAN/lib/Sort/Maker.pm:140]:18] or Sort::Maker::__ANON__[(eval 146)[/usr/local/src/github.com/foswiki/core/lib/CPAN/lib/Sort/Maker.pm:140]:18] or Sort::Maker::__ANON__[(eval 147)[/usr/local/src/github.com/foswiki/core/lib/CPAN/lib/Sort/Maker.pm:140]:18] or Sort::Maker::__ANON__[(eval 148)[/usr/local/src/github.com/foswiki/core/lib/CPAN/lib/Sort/Maker.pm:140]:18] or Sort::Maker::__ANON__[(eval 149)[/usr/local/src/github.com/foswiki/core/lib/CPAN/lib/Sort/Maker.pm:140]:18] or Sort::Maker::__ANON__[(eval 176)[/usr/local/src/github.com/foswiki/core/lib/CPAN/lib/Sort/Maker.pm:140]:18] or Sort::Maker::__ANON__[(eval 177)[/usr/local/src/github.com/foswiki/core/lib/CPAN/lib/Sort/Maker.pm:140]:18] or Sort::Maker::__ANON__[(eval 193)[/usr/local/src/github.com/foswiki/core/lib/CPAN/lib/Sort/Maker.pm:140]:18] or Sort::Maker::__ANON__[(eval 194)[/usr/local/src/github.com/foswiki/core/lib/CPAN/lib/Sort/Maker.pm:140]:18] or Sort::Maker::__ANON__[(eval 195)[/usr/local/src/github.com/foswiki/core/lib/CPAN/lib/Sort/Maker.pm:140]:18] or Sort::Maker::__ANON__[(eval 236)[/usr/local/src/github.com/foswiki/core/lib/CPAN/lib/Sort/Maker.pm:140]:18] at line 16 of (eval 136)[/usr/local/src/github.com/foswiki/core/lib/CPAN/lib/Sort/Maker.pm:140], avg 78µs/call | |||||
# spent 530µs within Sort::Maker::CORE:subst which was called 180 times, avg 3µs/call:
# 60 times (200µs+0s) by Sort::Maker::_make_ST_sort at line 587, avg 3µs/call
# 60 times (168µs+0s) by Sort::Maker::_make_ST_sort at line 599, avg 3µs/call
# 60 times (162µs+0s) by Sort::Maker::_make_ST_sort at line 597, avg 3µs/call | |||||
# spent 273µs within Sort::Maker::CORE:substcont which was called 120 times, avg 2µs/call:
# 120 times (273µs+0s) by Sort::Maker::_make_ST_sort at line 599, avg 2µs/call |