initial commit

[urisagit/Sort-Maker.git] / exp / bar2

my %is_boolean_opt = map { $_ => 1 } qw(
	descending
	no_case
	ref_in
	ref_out
	GRT_refs
) ;

my %is_value_opt = map { $_ => 1 } qw(
	name
) ;

my %is_key = map { $_ => 1 } qw(
	string
	string
	number
	integer
) ;

my %sort_makers = (

	plain	=> \&make_plain_sort,
	ST	=> \&make_ST_sort,
	GRT	=> \&make_GRT_sort,
) ;

my %sources ;
my $error_source ;


use Data::Dumper ;

sub sorter_source {

	$sources{ +shift } || $error_source ;
}

sort_maker() ;


sub sort_maker {

	my( $options, $keys ) = process_options( @ARGV ) ;

print Dumper $options, $keys ;

	die "no keys specified" unless @{$keys} ;	

	my $sort_maker = $sort_makers{ $options->{style} } ;

	die "no sort style selected" unless $sort_maker ;

	my $source = $sort_maker( $keys ) ;

	my $sorter = eval $source ;

	die "bad source $@" if $@ ;

	$sources{ $sorter } = $source ;

	if ( my $name = $options->{name} ) {

		no strict 'refs' ;

		my $package = (caller())[0] ;

		*${"${package}::$name"} = $sorter ;
	}

	return $sorter ;
}

sub process_options {

	my( %options, @keys ) ;

	while( @_ ) {

		my $opt = shift ;

		if ( $sort_makers{ $opt } ) {

			if ( @keys ) {
				die "no options after keys"
			}
	
			if ( $options{ style } ) {

				die
			"style was already set to $options{ style }" ;
			}

			$options{ style } = $opt ;
			next ;
		}

		if ( $is_boolean_opt{ $opt } ) {

			if ( @keys ) {
				die "no options after keys"
			}

			$options{ $opt } = 1 ;
			next ;
		}

		if ( $is_value_opt{ $opt } ) {

			if ( @keys ) {
				die "no value options after keys"
			}

			unless( @_ ) {

				die "no value for option $opt"
			}

			$options{ $opt } = shift ;
			next ;
		}

		if ( my( $order, $key, $case ) =
				$opt =~ /^([+-])?([a-z]+)(_\w+)?$/ ) {

			unless( $is_key{ $key } ) {

				die "unknown option '$opt'" ;
			}

			my $descend = ( $order || '' eq '+' ) ? 0 :
					$options{ 'descending' } ;

			my $nocase = $opt =~ s/_nocase$// ||
					$options{ nocase } ;

			$opt = 'numeric' if $opt eq 'integer' &&
					!$options{GRT} ;

			my $code = $_[0] ;

			unless ( defined( $code ) ||
				 ( $code =~ /^([+-])?(\w+)$/ && $is_key{ $2 } ) ) {

				$code = '$_' ;
			}
			else {
				shift ;
			}

			push( @keys, {

				key => $key,
				no_case => $nocase,
				descend => $descend,
				code => $code,
			} ) ;

			next ;
		}

		die "unknown option or key '$opt'" ;
	}

	return( \%options, \@keys ) ;
}

__END__


sub build_st {

	my( @st_compares, @st_extracts ) ;
	my $st_ind = '1' ;

	foreach my $key ( @keys ) {

		my $st_compare = <<'CMP' ;
	$a->[1] cmp $b->[1]
CMP

		$st_compare =~ tr/ab/ba/ if $key->{descending} ;
		$st_compare =~ s/cmp/<=>/ if $key->{numeric} ;
		$st_compare =~ s/1/$st_ind/g ;

		$st_ind++ ;

		push( @st_compares, $st_compare ) ;

		my $st_extract = <<EXT
	uc do{ $key->{code} }
EXT

		$st_extract =~ s/uc// if $key->{no_case} ;

		push( @st_extracts, $st_extract ) ;
	}

	my $compare_source = join "||\n", @st_compares ;

	my $extract_source = join ",\n", @st_extracts ;

	my $source = <<SUB ;
sub {
	map $_->[0],
	sort {
$compare_source
	}
	map [ $_,
$extract_source
	], @_
}
SUB

}

sub build_plain {

	my( @plain_compares ) 

	foreach my $key ( @keys ) {

		my $plain_compare = <<'CMP' ;
	do{ my( \$left, \$right ) = map { $key->{code} } \$a, \$b;
		\$left cmp \$right }
CMP

		$plain_compare =~ s/\$a, \$b/\$b, \$a/ if $key->{descending} ;
		$plain_compare =~ s/cmp/<=>/ if $key->{numeric} ;
		$plain_compare =~ s/=/= map uc,/ if $key->{no_case} ;

		push( @st_compares, $st_compare ) ;

		push( @st_extracts, $st_extract ) ;
	}

	my $compare_source = join "||\n", @st_compares ;

	my $source = <<SUB ;
sub {
	sort { sort { $compare_source } @_ ;
}
SUB

}

sub build_grt {

	my( @st_compares, @st_extracts ) ;
	my $st_ind = '1' ;

	foreach my $key ( @keys ) {

		push( @st_compares, $st_compare ) ;

		my $st_extract = <<EXT
	uc do{ $key->{code} }
EXT

		$st_extract =~ s/uc// if $key->{no_case} ;

		push( @st_extracts, $st_extract ) ;
	}

	my $extract_source = join ",\n", @st_extracts ;

	my $source = <<SUB ;
sub {
	map $_->[0],
	sort
	pack
$extract_source
	, @_ ;
}
SUB

}