← Index
NYTProf Performance Profile   « block view • line view • sub view »
For /usr/local/src/github.com/foswiki/core/bin/view
  Run on Sun Dec 4 17:17:59 2011
Reported on Sun Dec 4 17:26:51 2011

Filename/usr/local/src/github.com/foswiki/core/lib/CPAN/lib/Sort/Maker.pm
StatementsExecuted 4487 statements in 22.8ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
20115.57ms17.6msSort::Maker::::make_sorterSort::Maker::make_sorter
80213.22ms3.22msSort::Maker::::_has_mutex_attrsSort::Maker::_has_mutex_attrs
20112.73ms5.96msSort::Maker::::_process_defaultsSort::Maker::_process_defaults
20112.64ms3.44msSort::Maker::::_make_ST_sortSort::Maker::_make_ST_sort
20111.90ms7.85msSort::Maker::::_process_argumentsSort::Maker::_process_arguments
20111.55ms1.55msSort::Maker::::CORE:sortSort::Maker::CORE:sort (opcode)
2011690µs690µsSort::Maker::::_get_extractor_codeSort::Maker::_get_extractor_code
18031530µs530µsSort::Maker::::CORE:substSort::Maker::CORE:subst (opcode)
12011273µs273µsSort::Maker::::CORE:substcontSort::Maker::CORE:substcont (opcode)
11130µs127µsSort::Maker::::BEGIN@6Sort::Maker::BEGIN@6
11126µs35µsSort::Maker::::BEGIN@3Sort::Maker::BEGIN@3
11124µs211µsSort::Maker::::BEGIN@4Sort::Maker::BEGIN@4
11120µs61µsSort::Maker::::BEGIN@159Sort::Maker::BEGIN@159
43111µs11µsSort::Maker::::CORE:packSort::Maker::CORE:pack (opcode)
0000s0sSort::Maker::::__ANON__[:139]Sort::Maker::__ANON__[:139]
0000s0sSort::Maker::::_make_GRT_number_keySort::Maker::_make_GRT_number_key
0000s0sSort::Maker::::_make_GRT_sortSort::Maker::_make_GRT_sort
0000s0sSort::Maker::::_make_GRT_string_keySort::Maker::_make_GRT_string_key
0000s0sSort::Maker::::_make_orcish_sortSort::Maker::_make_orcish_sort
0000s0sSort::Maker::::_make_plain_sortSort::Maker::_make_plain_sort
0000s0sSort::Maker::::_process_array_attrsSort::Maker::_process_array_attrs
0000s0sSort::Maker::::sorter_sourceSort::Maker::sorter_source
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Sort::Maker;
2
3253µs243µ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
use strict;
# spent 35µs making 1 call to Sort::Maker::BEGIN@3 # spent 8µs making 1 call to strict::import
4262µs2399µ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
use base qw(Exporter);
# spent 211µs making 1 call to Sort::Maker::BEGIN@4 # spent 187µs making 1 call to base::import
5
62926µs2224µ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
use Data::Dumper ;
# spent 127µs making 1 call to Sort::Maker::BEGIN@6 # spent 97µs making 1 call to Exporter::import
7
813µsour @EXPORT = qw( make_sorter );
915µsour %EXPORT_TAGS = ( 'all' => [ qw( sorter_source ), @EXPORT ] );
1026µsour @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
11
1212µsour $VERSION = '0.06';
13
14
15# get integer and float sizes endian order
16
17116µs15µsmy $FLOAT_LEN = length pack "d", 1 ;
# spent 5µs making 1 call to Sort::Maker::CORE:pack
1818µs12µsmy $INT_LEN = length pack "N", 1 ;
# spent 2µs making 1 call to Sort::Maker::CORE:pack
1912µsmy $INT_BIT_LEN = $INT_LEN * 8 ;
20112µs24µsmy $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
2214µsmy @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
3512µsmy @value_attrs = qw(
36 fixed
37) ;
38
3914µsmy @grt_num_attrs = qw(
40 signed
41 unsigned
42 signed_float
43 unsigned_float
44) ;
45
4612µsmy @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
5414µsmy @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
641136µsmy %is_boolean_attr = map { $_ => 1 } @boolean_attrs ;
6539µsmy %is_value_attr = map { $_ => 1 } @value_attrs, 'code' ;
66
6712µsmy @boolean_args = qw(
68 ref_in
69 ref_out
70 string_data
71) ;
72
7312µsmy @value_args = qw(
74 name
75 init_code
76) ;
77
78# all the attributes can be set with defaults
79
801443µsmy %is_boolean_arg = map { $_ => 1 } @boolean_args, @boolean_attrs ;
81411µsmy %is_value_arg = map { $_ => 1 } @value_args, @value_attrs ;
82
8312µsmy @key_types = qw(
84 string
85 number
86) ;
87
88312µsmy %is_key_arg = map { $_ => 1 } @key_types ;
89
9014µsmy %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
98114µsmy %is_arg = ( %is_key_arg, %sort_makers, %is_value_arg, %is_boolean_arg ) ;
99
10011µsmy %sources ;
101
102# this is a file lexical so the WARN handler sub can see it.
103
10412µsmy $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
sub make_sorter {
107
108# clear any leftover errors
109
1102801.01ms $@ = '' ;
111
112# process @_ without copying it (&sub with no args)
113
114207.85ms my( $options, $keys, $closures ) = &_process_arguments ;
# spent 7.85ms making 20 calls to Sort::Maker::_process_arguments, avg 393µs/call
115 return unless $keys ;
116
11720690µ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 return if $@ ;
120
121# get the sort maker for this style and build the sorter
122
123 my $sort_maker = $sort_makers{ $options->{style} } ;
124203.44ms my $source = $sort_maker->( $options, $keys ) ;
# spent 3.44ms making 20 calls to Sort::Maker::_make_ST_sort, avg 172µs/call
125 return unless $source ;
126
127# prepend code to access any closures
128
129 if ( @closures ) {
130
131 my $closure_text = join '', map <<CLOSURE, 0 .. $#closures ;
132my \$closure$_ = \$closures[$_] ;
133CLOSURE
134
135 $source = "use strict ;\n$closure_text\n$source" ;
136 }
137
138404.34ms my $sorter = do {
139 local( $SIG{__WARN__} ) = sub { $eval_warnings .= $_[0] } ;
140 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 $sources{ $sorter || '' } = $source ;
144
145 $@ = <<ERR, return unless $sorter ;
146
147sort_maker: Can't compile this source for style $options->{style}.
148Check the key extraction code for errors.
149
150$source
151$eval_warnings
152$@
153ERR
154
155# install the sorter sub in the caller's package if a name was set
156
157 if ( my $name = $options->{name} ) {
158
15924.10ms2102µ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
no strict 'refs' ;
# 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 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
sub _process_arguments {
170
171120398µs my( %options, @keys ) ;
172
173 while( @_ ) {
174
175340602µs my $opt = shift ;
176
177100199µs if ( $sort_makers{ $opt } ) {
178
179 $@ =
180 "make_sorter: Style was already set to '$options{ style }'",
181 return if $options{ style } ;
182
183# handle optional boolean => 1
184 shift if @_ && $_[0] eq '1' ;
185 $options{ style } = $opt ;
186 $options{ $opt } = 1 ;
187
188 next ;
189 }
190
191 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 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
208420699µs if ( $is_key_arg{ $opt } ) {
209
210 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 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 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 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 shift ;
250 push( @keys, {
251 type => $opt,
252 code => $key_desc,
253 }
254 ) ;
255 next ;
256 }
257
258 $@ = "make_sorter: Unknown option or key '$opt'\n" ;
259 return ;
260 }
261
262 unless( @keys ) {
263 $@ = 'make_sorter: No keys specified' ;
264 return ;
265 }
266
267 unless( $options{style} ) {
268 $@ = 'make_sorter: No sort style selected' ;
269 return ;
270 }
271
272205.96ms return unless _process_defaults( \%options, \@keys ) ;
# spent 5.96ms making 20 calls to Sort::Maker::_process_defaults, avg 298µs/call
273
274 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
sub _process_defaults {
278
279100416µs my( $opts, $keys ) = @_ ;
280
28120884µ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 $opts->{init_code} ||= '' ;
284
2852028µs foreach my $key ( @{$keys} ) {
286
2873001.15ms602.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 $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 $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
30260413µs unless( grep( $key->{$_}, @grt_num_attrs ) ) {
303
304120165µs @{$key}{@grt_num_attrs} = @{$opts}{@grt_num_attrs} ;
305 }
306
30760295µs unless( grep( $key->{$_}, @grt_string_attrs ) ) {
308
309 @{$key}{@grt_string_attrs} =
310120151µs @{$opts}{@grt_string_attrs} ;
311 }
312 }
313
314 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
sub _get_extractor_code {
319
32080275µs my( $opts, $keys ) = @_ ;
321
322 my( @closures, $deparser ) ;
323
3242028µs foreach my $key ( @{$keys} ) {
325
326240410µs my $extract_code = $key->{code} ;
327
328# default extract code is $_
329
330 unless( $extract_code ) {
331
332 $key->{code} = '$_' ;
333 next ;
334 }
335
336 my $extractor_type = ref $extract_code ;
337
338# leave the extractor code alone if it is a string
339
340 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 ;
381Can't use CODE as key extractor unless B::Deparse module installed
382ERR
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 return @closures ;
404}
405
406
407# this is used to check for any mutually exclusive attribute in
408# defaults or keys
409
410
# spent 3.22ms within Sort::Maker::_has_mutex_attrs which was called 80 times, avg 40µs/call: # 60 times (2.34ms+0s) by Sort::Maker::_process_defaults at line 287, avg 39µs/call # 20 times (884µs+0s) by Sort::Maker::_process_defaults at line 281, avg 44µs/call
sub _has_mutex_attrs {
411
412240830µs my( $href, $name ) = @_ ;
413
414 foreach my $mutex ( @mutex_attrs ) {
415
4169602.53ms my @bad_attrs = grep $href->{$_}, @{$mutex} ;
417
418 next if @bad_attrs <= 1 ;
419
420 $@ = "make_sorter: Key attribute conflict: '$name @bad_attrs'";
421 return 1 ;
422 }
423
424 return ;
425}
426
427sub _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
462sub _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 }
473CMP
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 ;
495sub {
496use strict ;
497use warnings ;
498 $options->{init_code}
499 $open_bracket
500 sort {
501$compare_source
502 } $input $close_bracket ;
503}
504SUB
505
506 return $source ;
507}
508
509sub _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 )
529CMP
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 ;
557sub {
558 $options->{init_code}
559 my ( $cache_dcl ) ;
560
561 $open_bracket
562 sort {
563$compare_source
564 } $input $close_bracket ;
565}
566SUB
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
sub _make_ST_sort {
572
573180558µs my( $options, $keys ) = @_ ;
574
575 my( @st_compares, @st_extracts ) ;
576 my $st_ind = '1' ;
577
5782029µs foreach my $key ( @{$keys} ) {
579
580#print Dumper $key ;
581
5826002.87ms my $st_compare = <<CMP ;
583 \$a->[$st_ind] cmp \$b->[$st_ind]
584CMP
585
586 $st_compare =~ tr/ab/ba/ if $key->{descending} ;
58760200µ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 $st_ind++ ;
590
591 push( @st_compares, $st_compare ) ;
592
593 my $st_extract = <<EXT ;
594 do{ my (\$val) = EXTRACT ; uc \$val }
595EXT
596
59760162µ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} ;
599180441µ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 chomp( $st_extract ) ;
602 push( @st_extracts, $st_extract ) ;
603 }
604
605# build the full compare block
606
607 my $compare_source = join "\t\t||\n", @st_compares ;
608
609# build the full code for the key extracts
610
611 my $extract_source = join ",\n", @st_extracts ;
612
613# handle the in/out as ref options
614
615 my $input = $options->{ref_in} ? '@{$_[0]}' : '@_' ;
616 my( $open_bracket, $close_bracket ) = $options->{ref_out} ?
617 qw( [ ] ) : ( '', '' ) ;
618
619 my $source = <<SUB ;
620sub {
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}
631SUB
632
633}
634
635sub _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 ;
695unpack( 'N', substr( \$_, -$INT_LEN ) )
696INDEX
697 chomp $get_index_code ;
698
699 my $source = $options->{string_data} ? <<STRING_DATA : <<REF_DATA ;
700sub {
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}
712STRING_DATA
713sub {
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}
725REF_DATA
726
727#print $source ;
728
729 return $source ;
730}
731
732# code string to pack a float key value.
733
73412µsmy $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
74013µsmy $XOR_NEG = '\xFF' x $FLOAT_LEN ;
741
742sub _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 }
815CODE
816
817 return( $pack_format, $grt_extract, '' ) ;
818}
819
820sub _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 ;
831CODE
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 ) ;
845CODE
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 ;
851CODE
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} ;
862make_sorter: A GRT descending string needs to select either the
863'fixed' or 'varying' attributes
864ERR
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 }
873CODE
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
881sub sorter_source {
882
883 $sources{ +shift || '' } ;
884}
885
886141µs1 ;
887
888__END__
 
# spent 11µs within Sort::Maker::CORE:pack which was called 4 times, avg 3µs/call: # 2 times (4µs+0s) by Foswiki::Templates::BEGIN@483 at line 20, avg 2µs/call # once (5µs+0s) by Foswiki::Templates::BEGIN@483 at line 17 # once (2µs+0s) by Foswiki::Templates::BEGIN@483 at line 18
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
sub Sort::Maker::CORE:sort; # opcode
# 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
sub Sort::Maker::CORE:subst; # opcode
# 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
sub Sort::Maker::CORE:substcont; # opcode