Prompt::ReadKey - Darcs style single readkey option prompt.

	my $p = Prompt::ReadKey->new;

	my $name = $p->prompt(
		prompt => "blah",
		options => [
			{ name => "foo" },
			{
				name => "bar",
				default => 1,
				doc => "This is the bar command", # used in help message
				keys => [qw(b x)],                # defaults to substr($name, 0, 1)
			},
		],
	);

	Copyright (c) 2008 Yuval Kogman. All rights reserved
	This program is free software; you can redistribute
	it and/or modify it under the same terms as Perl itself.

#!/usr/bin/perl

package Prompt::ReadKey;
use Moose;

use Prompt::ReadKey::Util;

use Carp qw(croak);
use Term::ReadKey;
use List::Util qw(first);
use Text::Table;
use Text::Sprintf::Named;

our $VERSION = "0.03";

has default_prompt => (
	isa => "Str",
	is  => "rw",
);

has additional_options => (
	isa => "ArrayRef[HashRef]",
	is  => "rw",
	auto_deref => 1,
);

has auto_help => (
	isa => "Bool",
	is  => "rw",
	default => 1,
);

has help_headings => (
	isa => "ArrayRef[HashRef[Str]]",
	is  => "rw",
	default => sub {[
		{ name => "keys", heading => "Key" },
		{ name => "name", heading => "Name" },
		{ name => "doc",  heading => "Description" },
	]},
);

has help_header => (
	isa => "Str",
	is  => "rw",
	default => "The list of available commands is:",
);

has help_footer => (
	isa => "Str",
	is  => "rw",
);

has help_keys => (
	isa => "ArrayRef[Str]",
	is  => "rw",
	auto_deref => 1,
	default => sub { [qw(h ?)] },
);

has default_options => (
	isa => "ArrayRef[HashRef]",
	is  => "rw",
	auto_deref => 1,
);

has allow_duplicate_names => (
	isa => "Bool",
	is  => "rw",
	default => 0,
);

has readkey_mode => (
	isa => "Int",
	is  => "rw",
	default => 0, # normal getc, change to get timed
);

has readmode => (
	isa => "Int",
	is  => "rw",
	default => 3, # cbreak mode
);

has echo_key => (
	isa => "Bool",
	is  => "rw",
	default => 1,
);

has auto_newline => (
	isa => "Bool",
	is  => "rw",
	default => 1,
);

has return_option => (
	isa => "Bool",
	is  => "rw",
	default => 0,
);

has return_name => (
	isa => "Bool",
	is  => "rw",
	default => 1,
);

has case_insensitive => (
	isa => "Bool",
	is  => "rw",
	default => 1,
);

has repeat_until_valid => (
	isa => "Bool",
	is  => "rw",
	default => 1,
);

has prompt_format => (
	isa => "Str",
	is  => "rw",
	default => '%(prompt)s [%(option_keys)s] ',
);

sub prompt {
	my ( $self, %args ) = @_;

	my @options = $self->prepare_options(%args);

	$self->do_prompt(
		%args,
		options      => \@options,
		prompt       => $self->format_prompt( %args, options => \@options, option_count => scalar(@options) ),
	);
}

sub do_prompt {
	my ( $self, %args ) = @_;

	my $repeat = $self->_get_arg_or_default( repeat_until_valid => %args );

	prompt: {
		if ( my $opt = $self->prompt_once(%args) ) {

			if ( $opt->{reprompt_after} ) { # help, etc
				$self->option_to_return_value(%args, option => $opt); # trigger callback
				redo prompt;
			}

			return $self->option_to_return_value(%args, option => $opt);
		}

		redo prompt if $repeat;
	}

	return;
}

sub prompt_once {
	my ( $self, %args ) = @_;

	$self->print_prompt(%args);
	$self->read_option(%args);
}

sub print_prompt {
	my ( $self, %args ) = @_;
	$self->print($self->_get_arg_or_default( prompt => %args ));
}

sub print {
	my ( $self, @args ) = @_;
	local $| = 1;
	print @args;
}

sub prepare_options {
	my ( $self, %args ) = @_;

	$self->filter_options(
		%args,
		options => [
			$self->sort_options(
				%args,
				options => [
					$self->process_options(
						%args,
						options => [ $self->gather_options(%args) ]
					),
				],
			),
		],
	);
}

sub process_options {
	my ( $self, @args ) = @_;
	map { $self->process_option( @args, option => $_ ) } $self->_get_arg_or_default(options => @args);
}

sub process_option {
	my ( $self, %args ) = @_;
	my $opt = $args{option};

	my @keys = $opt->{key} ? delete($opt->{key}) : @{ $opt->{keys} || [] };

	unless ( @keys ) {
		croak "either 'key', 'keys', or 'name' is a required option" unless $opt->{name};
		@keys = ( substr $opt->{name}, 0, 1 );
	}

	$opt->{keys} = \@keys;

	return $opt;
}

sub gather_options {
	my ( $self, %args ) = @_;

	return (
		# explicit or default options
		$self->_get_arg_or_default(options => %args),

		# static additional options from the object *and* options passed on the arg list
		$self->additional_options(),
		_get_arg(additional_options => %args),

		# the help command
		$self->create_help_option(%args),
	);
}

sub get_help_keys {
	my ( $self, @args ) = @_;

	if ( $self->_get_arg_or_default( auto_help => @args ) ) {
		return $self->_get_arg_or_default( help_keys => @args );
	}
}

sub create_help_option {
	my ( $self, @args ) = @_;

	if ( my @keys = $self->get_help_keys(@args) ) {
		return {
			reprompt_after => 1,
			doc            => "List available commands",
			name           => "help",
			keys           => \@keys,
			callback       => "display_help",
			is_help        => 1,
			special_option => 1,
		}
	}

	return;
}

sub display_help {
	my ( $self, @args ) = @_;

	my @options = $self->_get_arg_or_default(options => @args);

	my $help = join("\n\n", grep { defined }
		$self->_get_arg_or_default(help_header => @args),
		$self->tabulate_help_text( @args, help_table => [ map { $self->option_to_help_text(@args, option => $_) } @options ] ),
		$self->_get_arg_or_default(help_footer => @args),
	);

	$self->print("\n$help\n\n");
}

sub tabulate_help_text {
	my ( $self, %args ) = @_;

	my @headings = $self->_get_arg_or_default( help_headings => %args );

	my $table = Text::Table->new( map { $_->{heading}, \"   " } @headings );

	my @rows = _get_arg( help_table => %args );

	$table->load( map {
		my $row = $_;
		[ map { $row->{ $_->{name} } } @headings ];
	} @rows );

	$table->body_rule("   ");

	return $table;
}

sub option_to_help_text {
	my ( $self, %args ) = @_;
	my $opt = $args{option};

	return {
		keys => join(", ", grep { /^[[:graph:]]+$/ } @{ $opt->{keys} } ),
		name => $opt->{name} || "",
		doc => $opt->{doc}  || "",
	};
}

sub sort_options {
	my ( $self, @args ) = @_;
	$self->_get_arg_or_default(options => @args);
}

sub filter_options {
	my ( $self, %args ) = @_;

	my @options = $self->_get_arg_or_default(options => %args);

	croak "No more than one default is allowed" if 1 < scalar grep { $_->{default} } @options;

	foreach my $field ( "keys", ( $self->_get_arg_or_default( allow_duplicate_names => %args ) ? "name" : () ) ) {
		my %idx;

		foreach my $option ( @options ) {
			my $value = $option->{$field};
			my @values = ref($value) ? @$value : $value;
			push @{ $idx{$_} ||= [] }, $option for grep { defined } @values;
		}

		foreach my $key ( keys %idx ) {
			delete $idx{$key} if @{ $idx{$key} } == 1;
		}

		if ( keys %idx ) {
			# FIXME this error sucks
			require Data::Dumper;
			croak "duplicate value for '$field': " . Dumper(\%idx);
		}
	}

	return @options;
}

sub prompt_string {
	my ( $self, @args ) = @_;
	if ( my $string = $self->_get_arg_or_default(prompt => @args) ) {
		return $self->format_string(
			@args,
			format => $string,
		);
	} else {
		croak "'prompt' argument is required";
	}
}

sub get_default_option {
	my ( $self, @args ) = @_;

	if ( my $default = $self->_get_arg_or_default( default_option => @args ) ) {
		return $default;
	} else {
		return first { $_->{default} } $self->_get_arg_or_default( options => @args );
	}
}

sub format_options {
	my ( $self, %args ) = @_;

	my $default_option = $self->get_default_option(%args);

	my @options = grep { not $_->{special_option} } $self->_get_arg_or_default(options => %args);

	if ( $self->_get_arg_or_default( case_insensitive => %args ) ) {
		return join "", map {
			my $default = $default_option == $_;
			map { $default ? uc : lc } grep { /^[[:graph:]]+$/ } @{ $_->{keys} };
		} @options;
	} else {
		return join "", grep { /^[[:graph:]]+$/ } map { @{ $_->{keys} } } @options;
	}
}

sub format_string {
	my ( $self, %args ) = @_;
	Text::Sprintf::Named->new({ fmt => $args{format} })->format({ args => \%args })
}

sub format_prompt {
	my ( $self, @args ) = @_;

	my $format = $self->_get_arg_or_default( prompt_format => @args );


	$self->format_string(
		@args,
		format => $format,
		prompt      => $self->prompt_string(@args),
		option_keys => $self->format_options(@args),
	);
}

sub read_option {
	my ( $self, @args ) = @_;

	my @options = $self->_get_arg_or_default(options => @args);

	my %by_key = map {
		my $opt = $_;
		map { $_ => $opt } map { $self->process_char( @args, char => $_ ) } @{ $_->{keys} };
	} @options;

	my $c = $self->process_char( @args, char => $self->read_key(@args) );

	if ( defined $c ) {
		if ( exists $by_key{$c} ) {
			return $by_key{$c};
		} elsif ( $c =~ /^\s+$/ ) {
			if ( my $default = $self->get_default_option(@args) ) {
				return $default;
			}
		}
	}

	$self->invalid_choice(@args, char => $c);

	return;
}

sub invalid_choice {
	my ( $self, %args ) = @_;

	my $output;
	my $c = $args{char};

	if ( defined($c) and $c =~ /^[[:graph:]]+$/ ) {
		$output = "'$c' is not a valid choice, please select one of the options.";
	} else {
		$output = "Invalid input, please select one of the options.";
	}

	if ( my @keys = $self->get_help_keys(%args) ) {
		$output .= " Enter '$keys[0]' for help.";
	}

	$self->print("$output\n");
}

sub option_to_return_value {
	my ( $self, %args ) = @_;

	my $opt = $args{option};

	if ( $opt->{special_option} ) {
		if ( my $cb = $opt->{callback} ) {
			return $self->$cb(%args);
		} else {
			return $opt;
		}
	} else {
		return $opt if $self->_get_arg_or_default(return_option => %args);

		if ( my $cb = $opt->{callback} ) {
			return $self->$cb(%args);
		} else {
			return (
				$self->_get_arg_or_default(return_name => %args)
					? $opt->{name}
					: $opt
			);
		}
	}
}

sub read_key {
	my ( $self, %args ) = @_;

    ReadMode( $self->_get_arg_or_default( readmode => %args ) );

	my $sigint = $SIG{INT} || sub { exit 1 };

    local $SIG{INT} = sub {
		ReadMode(0);
		print "\n" if $self->_get_arg_or_default( auto_newline => %args );
		$sigint->();
	};

	my $readkey_mode = $self->_get_arg_or_default( readkey_mode => %args );

	my $c = ReadKey($readkey_mode);

	if ( $c eq chr(0x1b) ) {
		$c .= ReadKey($readkey_mode);
		$c .= ReadKey($readkey_mode);
	}

    ReadMode(0);

    die "Error reading key from user: $!" unless defined($c);

    print $c if $c =~ /^[[:graph:]]+$/ and $self->_get_arg_or_default( echo_key => %args );

    print "\n" if $c ne "\n" and $self->_get_arg_or_default( auto_newline => %args );

    return $c;
}

sub process_char {
	my ( $self, %args ) = @_;

	my $c = $args{char};

	if ( $self->_get_arg_or_default( case_insensitive => %args ) ) {
		return lc($c);
	} else {
		return $c;
	}
}

__PACKAGE__

__END__