File Coverage

blib/lib/Ask/Tk.pm

Criterion	Covered	Total	%
statement	15	17	88.2
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	21	23	91.3

use 5.008008;
use strict;
use warnings;

package Ask::Tk;

our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '0.013';

use Moo;
use Path::Tiny 'path';
use Tk;
use namespace::autoclean;

with 'Ask::API';

sub is_usable {
	my ( $self ) = @_;
	return !!$ENV{'DISPLAY'};
}

sub quality {
	return 30;
}

sub info {
	my ( $self, %o ) = @_;

	my $mw = "MainWindow"->new;
	$mw->withdraw;

	$o{messagebox_type} ||= 'ok';
	$o{messagebox_icon} ||= 'info';

	my $r = $mw->messageBox(
		-title   => $o{title} || '',
		-message => $o{text}  || '',
		-type    => $o{messagebox_type},
		-icon    => $o{messagebox_icon},
	);
	$mw->destroy;
	return $r;
} #/ sub info

sub warning {
	my ( $self, %o ) = @_;
	$self->info( messagebox_icon => 'warning', %o );
}

sub error {
	my ( $self, %o ) = @_;
	$self->info( messagebox_icon => 'error', %o );
}

sub question {
	my ( $self, %o ) = @_;
	'Ok' eq $self->info(
		messagebox_icon => 'question',
		messagebox_type => 'OkCancel',
		%o,
	);
}

sub entry {
	my ( $self, %o ) = @_;
	my $mw = "MainWindow"->new;

	$mw->Label( -text => $o{text} )->pack
		if exists $o{text};

	my $return = $o{entry_text};
	my $entry  = $mw->Entry(
		( -show => '*' )x!!( $o{hide_text} ),
		-textvariable => \$return,
	)->pack;

	$entry->bind(
		'',
		[
			sub {
				$return = $entry->get;
				$mw->destroy;
			}
		]
	);

	$entry->focus;
	MainLoop;
	return $return;
} #/ sub entry

sub file_selection {
	my ( $self, %o ) = @_;
	my @files;
	my $mw = "MainWindow"->new;
	$mw->withdraw;

	my %TK = (
		-type => $o{directory} ? 'dir' : ( $o{save} ? 'save' : 'open' ),
	);

	push @files, path $mw->FBox( %TK )->Show;
	while ( $o{multiple} and $self->question( text => 'Select another?' ) ) {
		push @files, path $mw->FBox( %TK )->Show;
	}

	$mw->destroy;
	$o{multiple} ? @files : $files[0];
} #/ sub file_selection

sub _choice {
	my ( $self, %o ) = @_;
	my $mw = "MainWindow"->new;

	$mw->title( $o{title} );
	$mw->Label( -text => $o{text} )->pack if exists $o{text};

	my @return;
	my $lbox = $mw->Listbox( -selectmode => ( $o{_mode} || 'single' ) )->pack;
	$lbox->insert( end => map $_->[1], @{ $o{choices} } );

	$mw->Button(
		-text    => 'OK',
		-command => sub {
			@return = map $o{choices}[$_][0], $lbox->curselection;
			$mw->destroy;
		},
	)->pack;

	MainLoop;
	return @return;
} #/ sub _choice

sub multiple_choice {
	my ( $self, %o ) = @_;
	$o{title} = 'Choose' unless exists $o{title};
	$o{_mode} = 'multiple';
	my @r = $self->_choice( %o );
	return @r;
}

sub single_choice {
	my ( $self, %o ) = @_;
	$o{title} = 'Choose one' unless exists $o{title};
	$o{_mode} = 'single';
	my ( $r ) = $self->_choice( %o );
	return $r;
}

1;

__END__