exp/bar2

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