File Coverage

blib/lib/Sort/Maker.pm
Criterion Covered Total %
statement 284 295 96.2
branch 131 144 90.9
condition 28 42 66.6
subroutine 26 27 96.3
pod 2 2 100.0
total 471 510 92.3


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__