exp/bar1

   1 my %is_boolean_opt = map { $_ => 1 } qw(
   2         descending
   3         no_case
   4         ref_in
   5         ref_out
   6         GRT_refs
   7 ) ;
   8
   9 my %is_value_opt = map { $_ => 1 } qw(
  10         name
  11
  12 ) ;
  13
  14 my @key_types = qw(
  15         string
  16         string_case
  17         string_no_case
  18         number
  19         integer
  20 ) ;
  21
  22 my $key_alt = join '|', @key_types ;
  23 my $key_re = qr/^([+-])?($key_alt)$/ ;
  24
  25 my %sort_makers = (
  26
  27         plain   => \&make_plain_sort,
  28         ST      => \&make_ST_sort,
  29         GRT     => \&make_GRT_sort,
  30 ) ;
  31
  32 my %sources ;
  33 my $error_source ;
  34
  35
  36 use Data::Dumper ;
  37
  38 sub sorter_source {
  39
  40         $sources{ +shift } || $error_source ;
  41 }
  42
  43 sort_maker() ;
  44
  45
  46 sub sort_maker {
  47
  48         my( $options, $keys ) = process_options( @ARGV ) ;
  49
  50 print Dumper $options, $keys ;
  51
  52         die "no keys specified" unless @{$keys} ;
  53
  54 return ;
  55         my $sort_maker = $sort_makers{ $options->{style} } ;
  56
  57         die "no sort style selected" unless $sort_maker ;
  58
  59         my $source = $sort_maker->( $keys ) ;
  60
  61         my $sorter = eval $source ;
  62
  63         die "bad source $@" if $@ ;
  64
  65         $sources{ $sorter } = $source ;
  66
  67         if ( my $name = $options->{name} ) {
  68
  69                 no strict 'refs' ;
  70
  71                 my $package = (caller())[0] ;
  72
  73                 *${"${package}::$name"} = $sorter ;
  74         }
  75
  76         return $sorter ;
  77 }
  78
  79 sub process_options {
  80
  81         my( %options, @keys ) ;
  82
  83         while( @_ ) {
  84
  85                 my $opt = shift ;
  86
  87                 if ( $sort_makers{ $opt } ) {
  88
  89                         if ( @keys ) {
  90                                 die "no options after keys"
  91                         }
  92
  93                         if ( $options{ style } ) {
  94
  95                                 die
  96                         "style was already set to $options{ style }" ;
  97                         }
  98
  99                         $options{ style } = $opt ;
 100                         $options{ $opt } = 1 ;
 101
 102                         next ;
 103                 }
 104
 105                 if ( $is_boolean_opt{ $opt } ) {
 106
 107                         if ( @keys ) {
 108                                 die "no options after keys"
 109                         }
 110
 111                         $options{ $opt } = 1 ;
 112                         next ;
 113                 }
 114
 115                 if ( $is_value_opt{ $opt } ) {
 116
 117                         if ( @keys ) {
 118                                 die "no value options after keys"
 119                         }
 120
 121                         unless( @_ ) {
 122
 123                                 die "no value for option $opt"
 124                         }
 125
 126                         $options{ $opt } = shift ;
 127                         next ;
 128                 }
 129
 130                 if ( my( $order, $key ) = $opt =~ /$key_re/ ) {
 131
 132                         my $descend = ( $order || '' eq '+' ) ? 0 :
 133                                         $options{ 'descending' } ;
 134
 135
 136                         my $no_case = ( $key =~ s/_(no_)case// ) ?
 137                                 defined( $1 ) : $options{no_case} ;
 138
 139                         $key = 'number' if $key eq 'integer' &&
 140                                         !$options{GRT} ;
 141
 142                         my $code = $_[0] ;
 143
 144                         if ( defined( $code ) || ! $code =~ /$key_re/ ) {
 145
 146                                 shift ;
 147                         }
 148                         else {
 149
 150                                 $code = '$_' ;
 151                         }
 152
 153                         push( @keys, {
 154
 155                                 key => $key,
 156                                 no_case => $nocase,
 157                                 descend => $descend,
 158                                 code => $code,
 159                         } ) ;
 160
 161                         next ;
 162                 }
 163
 164                 die "unknown option or key '$opt'" ;
 165         }
 166
 167         return( \%options, \@keys ) ;
 168 }
 169
 170 __END__
 171
 172
 173 sub build_st {
 174
 175         my( @st_compares, @st_extracts ) ;
 176         my $st_ind = '1' ;
 177
 178         foreach my $key ( @keys ) {
 179
 180                 my $st_compare = <<'CMP' ;
 181         $a->[1] cmp $b->[1]
 182 CMP
 183
 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 ;
 187
 188                 $st_ind++ ;
 189
 190                 push( @st_compares, $st_compare ) ;
 191
 192                 my $st_extract = <<EXT
 193         uc do{ $key->{code} }
 194 EXT
 195
 196                 $st_extract =~ s/uc// if $key->{no_case} ;
 197
 198                 push( @st_extracts, $st_extract ) ;
 199         }
 200
 201         my $compare_source = join "||\n", @st_compares ;
 202
 203         my $extract_source = join ",\n", @st_extracts ;
 204
 205         my $source = <<SUB ;
 206 sub {
 207         map $_->[0],
 208         sort {
 209 $compare_source
 210         }
 211         map [ $_,
 212 $extract_source
 213         ], @_
 214 }
 215 SUB
 216
 217 }
 218
 219 sub build_plain {
 220
 221         my( @plain_compares )
 222
 223         foreach my $key ( @keys ) {
 224
 225                 my $plain_compare = <<'CMP' ;
 226         do{ my( \$left, \$right ) = map { $key->{code} } \$a, \$b;
 227                 \$left cmp \$right }
 228 CMP
 229
 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} ;
 233
 234                 push( @st_compares, $st_compare ) ;
 235
 236                 push( @st_extracts, $st_extract ) ;
 237         }
 238
 239         my $compare_source = join "||\n", @st_compares ;
 240
 241         my $source = <<SUB ;
 242 sub {
 243         sort { sort { $compare_source } @_ ;
 244 }
 245 SUB
 246
 247 }
 248
 249 sub build_grt {
 250
 251         my( @st_compares, @st_extracts ) ;
 252         my $st_ind = '1' ;
 253
 254         foreach my $key ( @keys ) {
 255
 256                 push( @st_compares, $st_compare ) ;
 257
 258                 my $st_extract = <<EXT
 259         uc do{ $key->{code} }
 260 EXT
 261
 262                 $st_extract =~ s/uc// if $key->{no_case} ;
 263
 264                 push( @st_extracts, $st_extract ) ;
 265         }
 266
 267         my $extract_source = join ",\n", @st_extracts ;
 268
 269         my $source = <<SUB ;
 270 sub {
 271         map $_->[0],
 272         sort
 273         pack
 274 $extract_source
 275         , @_ ;
 276 }
 277 SUB
 278
 279 }
 280
 281