1 my %is_boolean_opt = map { $_ => 1 } qw(
9 my %is_value_opt = map { $_ => 1 } qw(
22 my $key_alt = join '|', @key_types ;
23 my $key_re = qr/^([+-])?($key_alt)$/ ;
27 plain => \&make_plain_sort,
29 GRT => \&make_GRT_sort,
40 $sources{ +shift } || $error_source ;
48 my( $options, $keys ) = process_options( @ARGV ) ;
50 print Dumper $options, $keys ;
52 die "no keys specified" unless @{$keys} ;
55 my $sort_maker = $sort_makers{ $options->{style} } ;
57 die "no sort style selected" unless $sort_maker ;
59 my $source = $sort_maker->( $keys ) ;
61 my $sorter = eval $source ;
63 die "bad source $@" if $@ ;
65 $sources{ $sorter } = $source ;
67 if ( my $name = $options->{name} ) {
71 my $package = (caller())[0] ;
73 *${"${package}::$name"} = $sorter ;
81 my( %options, @keys ) ;
87 if ( $sort_makers{ $opt } ) {
90 die "no options after keys"
93 if ( $options{ style } ) {
96 "style was already set to $options{ style }" ;
99 $options{ style } = $opt ;
100 $options{ $opt } = 1 ;
105 if ( $is_boolean_opt{ $opt } ) {
108 die "no options after keys"
111 $options{ $opt } = 1 ;
115 if ( $is_value_opt{ $opt } ) {
118 die "no value options after keys"
123 die "no value for option $opt"
126 $options{ $opt } = shift ;
130 if ( my( $order, $key ) = $opt =~ /$key_re/ ) {
132 my $descend = ( $order || '' eq '+' ) ? 0 :
133 $options{ 'descending' } ;
136 my $no_case = ( $key =~ s/_(no_)case// ) ?
137 defined( $1 ) : $options{no_case} ;
139 $key = 'number' if $key eq 'integer' &&
144 if ( defined( $code ) || ! $code =~ /$key_re/ ) {
164 die "unknown option or key '$opt'" ;
167 return( \%options, \@keys ) ;
175 my( @st_compares, @st_extracts ) ;
178 foreach my $key ( @keys ) {
180 my $st_compare = <<'CMP' ;
184 $st_compare =~ tr/ab/ba/ if $key->{descending} ;
185 $st_compare =~ s/cmp/<=>/ if $key->{numeric} ;
186 $st_compare =~ s/1/$st_ind/g ;
190 push( @st_compares, $st_compare ) ;
192 my $st_extract = <<EXT
193 uc do{ $key->{code} }
196 $st_extract =~ s/uc// if $key->{no_case} ;
198 push( @st_extracts, $st_extract ) ;
201 my $compare_source = join "||\n", @st_compares ;
203 my $extract_source = join ",\n", @st_extracts ;
221 my( @plain_compares )
223 foreach my $key ( @keys ) {
225 my $plain_compare = <<'CMP' ;
226 do{ my( \$left, \$right ) = map { $key->{code} } \$a, \$b;
230 $plain_compare =~ s/\$a, \$b/\$b, \$a/ if $key->{descending} ;
231 $plain_compare =~ s/cmp/<=>/ if $key->{numeric} ;
232 $plain_compare =~ s/=/= map uc,/ if $key->{no_case} ;
234 push( @st_compares, $st_compare ) ;
236 push( @st_extracts, $st_extract ) ;
239 my $compare_source = join "||\n", @st_compares ;
243 sort { sort { $compare_source } @_ ;
251 my( @st_compares, @st_extracts ) ;
254 foreach my $key ( @keys ) {
256 push( @st_compares, $st_compare ) ;
258 my $st_extract = <<EXT
259 uc do{ $key->{code} }
262 $st_extract =~ s/uc// if $key->{no_case} ;
264 push( @st_extracts, $st_extract ) ;
267 my $extract_source = join ",\n", @st_extracts ;