use 5.008008;
use strict;
use warnings;
package Ask::Tk;
our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION = '0.015';
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(
'<Return>',
[
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__
=head1 NAME
Ask::Tk - interact with a user via a GUI
=head1 SYNOPSIS
my $ask = Ask::Tk->new;
$ask->info(text => "I'm Charles Xavier");
if ($ask->question(text => "Would you like some breakfast?")) {
...
}
=head1 BUGS
Please report any bugs to
L<http://rt.cpan.org/Dist/Display.html?Queue=Ask>.
=head1 SEE ALSO
L<Ask>.
=head1 AUTHOR
Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
=head1 COPYRIGHT AND LICENCE
This software is copyright (c) 2012-2013, 2020 by Toby Inkster.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=head1 DISCLAIMER OF WARRANTIES
THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.