Jason McVeigh wrote:
ATTN: Phillip Bradey RE: Tk Options
#!/bin/perl -w
package Application {
use Moose;
use Tk;
require Tk::BrowseEntry;
use feature 'say';
use feature 'state';
use feature 'switch';
use namespace::autoclean;
has '_mw' => (
is => 'rw',
isa => 'Tk::MainWindow',
);
has '_packdirs' => (
is => 'rw',
isa => 'ArrayRef',
required => 1,
default => sub { [] },
);
has '_top' => (
is => 'rw',
isa => 'Tk::Widget',
);
sub _build_mw {
my ($self) = @_;
my $numWidgets = 4;
$self->_mw(MainWindow->new(-title => "Tk Options"));
my $ft1 = $self->_mw->Frame(
-borderwidth => 2,
-relief => 'groove',
)->pack(
-side => 'top',
-fill => 'y',
);
my $f1 = $ft1->Frame(
-borderwidth => 2,
-relief => 'groove'
)->pack(
-side => 'left',
);
my $f2 = $ft1->Frame(
-borderwidth => 2,
-relief => 'groove'
)->pack(
-side => 'left',
);
my $f3 = $ft1->Frame(
-borderwidth => 2,
-relief => 'groove'
)->pack(
-side => 'left',
);
my $f4 = $ft1->Frame(
-borderwidth => 2,
-relief => 'groove'
)->pack(
-side => 'left',
);
my $ft2 = $self->_mw->Frame(
-borderwidth => 2,
-relief => 'groove',
)->pack(
-side => 'bottom',
-fill => 'y',
);
my $f5 = $ft2->Frame(
-borderwidth => 2,
-relief => 'groove'
)->pack(
-side => 'left',
);
my $f6 = $ft2->Frame(
-borderwidth => 2,
-relief => 'groove'
)->pack(
-side => 'left',
-fill => 'x'
);
my $f7 = $ft2->Frame(
-borderwidth => 2,
-relief => 'groove'
)->pack(
-side => 'left',
);
my $f8 = $ft2->Frame(
-borderwidth => 2,
-relief => 'groove'
)->pack(
-side => 'left',
);
my $i = 0;
my $lbl1 = $f1->Label(-text => 'Configuration 1')->pack(-ipady
=> 5);
my $lbl2 = $f2->Label(-text => 'Configuration 2')->pack(-ipady
=> 5);
my $lbl3 = $f3->Label(-text => 'Configuration 3')->pack(-ipady
=> 5);
my $lbl4 = $f4->Label(-text => 'Configuration 4')->pack(-ipady
=> 5);
my $lbl5 = $f5->Label(-text => 'Configuration 5')->pack(-ipady
=> 5);
my $lbl6 = $f6->Label(-text => 'Configuration 6')->pack(-ipady
=> 5);
my $lbl7 = $f7->Label(-text => 'Configuration 7')->pack(-ipady
=> 5);
my $lbl8 = $f8->Label(-text => 'Configuration 8')->pack(-ipady
=> 5);
foreach (0..$numWidgets)
{
$self->_packdirs->[$_] = 'Skip';
my $be1 = $f1->BrowseEntry(-label => "Setting $_:",
-choices => ["On", "Off", "Skip"],
-variable => \$self->_packdirs->[$_], -browsecmd =>
\&repack)
->pack(-ipady => 5);
my $be2 = $f2->BrowseEntry(-label => "Setting $_:",
-choices => ["On", "Off", "Skip"],
-variable => \$self->_packdirs->[$_], -browsecmd =>
\&repack)
->pack(-ipady => 5);
my $be3 = $f3->BrowseEntry(-label => "Setting $_:",
-choices => ["On", "Off", "Skip"],
-variable => \$self->_packdirs->[$_], -browsecmd =>
\&repack)
->pack(-ipady => 5);
my $be4 = $f4->BrowseEntry(-label => "Setting $_:",
-choices => ["On", "Off", "Skip"],
-variable => \$self->_packdirs->[$_], -browsecmd =>
\&repack)
->pack(-ipady => 5);
my $be5 = $f5->BrowseEntry(-label => "Setting $_:",
-choices => ["On", "Off", "Skip"],
-variable => \$self->_packdirs->[$_], -browsecmd =>
\&repack)
->pack(-ipady => 5);
my $be6 = $f6->BrowseEntry(-label => "Setting $_:",
-choices => ["On", "Off", "Skip"],
-variable => \$self->_packdirs->[$_], -browsecmd =>
\&repack)
->pack(-ipady => 5);
my $be7 = $f7->BrowseEntry(-label => "Setting $_:",
-choices => ["On", "Off", "Skip"],
-variable => \$self->_packdirs->[$_], -browsecmd =>
\&repack)
->pack(-ipady => 5);
my $be9 = $f8->BrowseEntry(-label => "Setting $_:",
-choices => ["On", "Off", "Skip"],
-variable => \$self->_packdirs->[$_], -browsecmd =>
\&repack)
->pack(-ipady => 5);
}
my $btn1 = $f1->Button(-text => 'Commence New Process
1')->pack(-ipady => 5);
my $btn2 = $f2->Button(-text => 'Commence New Process
2')->pack(-ipady => 5);
my $btn3 = $f3->Button(-text => 'Commence New Process
3')->pack(-ipady => 5);
my $btn4 = $f4->Button(-text => 'Commence New Process
4')->pack(-ipady => 5);
my $btn5 = $f5->Button(-text => 'Commence New Process
5')->pack(-ipady => 5);
my $btn6 = $f6->Button(-text => 'Commence New Process
6')->pack(-ipady => 5);
my $btn7 = $f7->Button(-text => 'Commence New Process
7')->pack(-ipady => 5);
my $btn8 = $f8->Button(-text => 'Commence New Process
8')->pack(-ipady => 5);
$self->_top($self->_mw->Toplevel(-title => "output window"));
my $c;
my $idx = 0;
foreach (@{$self->_packdirs})
{
my $b = $self->_top->Button(-text => "Open Folder
${idx}", -font => "Courier 20 bold")->pack(-side => 'bottom', -fill =>
'both', -expand => 1);
$idx++;
}
MainLoop;
}
sub main {
my ($self) = @_;
$self->_build_mw;
}
__PACKAGE__->meta->make_immutable;
}
my $app = Application->new->main unless caller;
1;
Great. This is also available as a Public Gist upon GitHub. The url
for the Gist is
https://gist.github.com/jmcveigh/48c71a3b555eea631a00c13e9162c433
Click link above for the source code response regarding options in Tk.
Okay.
Warm Regards,
Jason McVeigh
Jeff Hobbs wrote:
I believe <Return> may be the default action, where <Space> is what
you need to press to get the right action. You’ll see OS X behave the
same way with its core ok/cancel boxes.
On Jun 14, 2016, at 10:29 AM, Philip Brady <phil.br...@hotmail.co.uk
<mailto:phil.br...@hotmail.co.uk>> wrote:
I'm writing a perl script using Tk and have had some success but I
wish to have a very simple subroutine to ask the user a question and
get a response 'ok' or 'cancel'.
My routine follows but it doesn't quite work as expected.
It's fine if I mouse click on 'ok' or simply press the return key -
it correctly returns 'ok'.
If I clink 'cancel' it correctly returns 'cancel'.
Unfortunately, if I tab to 'cancel' then press return it returns
'ok' rather than the desired 'cancel'.
I'd appreciate any advice on fixing this.
regards
Phil
The code is:
#!/usr/bin/perl -w
use strict;
use Tk;
use Tk::Dialog;
use Tk::DialogBox;
my $main=MainWindow->new();
my $X=CheckOk('Some old question');
print "Response was $X\n";
exit 0;
sub CheckOk{
(my $question)=@_;
my $box=$main->DialogBox(
-buttons => ['ok','cancel'],
-default_button => "ok");
$box-> add("Label",
-text => "$question ")->pack;
$box -> Show();
}
ATTN: Philip Brady RE: Tk Options
Hi. I thought I would log a bit more time on this piece. I did some
more on my topic. This is an abstract for Tk Options.
#!/bin/perl -w
package Application {
use Moose;
use Tk;
require Tk::BrowseEntry;
use feature 'say';
use feature 'state';
use feature 'switch';
use namespace::autoclean;
has '_mw' => (
is => 'rw',
isa => 'Tk::MainWindow',
);
has '_packdirs' => (
is => 'rw',
isa => 'ArrayRef',
required => 1,
default => sub { [] },
);
has '_top' => (
is => 'rw',
isa => 'Tk::Widget',
);
has '_fh' => (
is => 'ro',
isa => 'ArrayRef[Tk::Frame]',
default => sub { [] },
);
has '_f' => (
is => 'ro',
isa => 'ArrayRef[Tk::Frame]',
default => sub { [] },
);
use YAML::Tiny;
sub _build_mw {
my ($self) = @_;
my $numWidgets = 4;
my $yaml = YAML::Tiny->read('tk-options-labels.yml');
$self->_mw(MainWindow->new(-title => "Tk Options"));
# create top, bottom, left and right frames
my %def_fh1 = (
'side' => 'top', 'fill' => 'y','cells' => 3,
);
my %def_fh2 = (
'side' => 'bottom', 'fill' => 'y','cells' => 3,
);
my %def_fh3 = (
'side' => 'left', 'fill' => 'x','cells' => 1,
);
my %def_fh4 = (
'side' => 'right', 'fill' => 'x','cells' => 1,
);
my @def_fh = (\%def_fh1,\%def_fh2,\%def_fh3,\%def_fh4);
my ($idx_fh, $idx_f, $idx_be) = (0,0,0);
# create widgits within top and bottom frames
for (0 .. 3) {
push @{$self->_fh}, $self->_mw->Frame(
-borderwidth => 2,
-relief => 'groove',
)->pack(
-side => $def_fh[$idx_fh]{'side'},
-fill => $def_fh[$idx_fh]{'fill'},
);
say $def_fh[$idx_fh]{'side'};
for (0 .. $def_fh[$idx_fh]{'cells'}) {
push @{$self->_f}, $self->_fh->[$idx_fh]->Frame(
-borderwidth => 2,
-relief => 'groove'
)->pack(
-side => 'left',
);
$self->_f->[$idx_f]->Label(-text =>
$yaml->[0]->[$idx_f]->{'header'})->pack(-ipady => 5);
for (0 .. 5) {
$self->_packdirs->[$idx_be] = 'Skip';
$self->_f->[$idx_f]->BrowseEntry(-label =>
$yaml->[0]->[$idx_f]->{'options'}->[$_],
-choices => ["On", "Off", "Skip"],
-variable => \$self->_packdirs->[$idx_be],
-browsecmd => \&repack)
->pack(-ipady => 5);
$idx_be++;
}
$self->_f->[$idx_f]->Button(-text =>
$yaml->[0]->[$idx_f]->{'cta'})->pack(-ipady => 5);
$idx_f++;
}
$idx_fh++;
}
$self->_top($self->_mw->Toplevel(-title => "File Options"));
my $c;
my $idx = 0;
foreach (0 .. 8)
{
my $b = $self->_top->Button(-text => "Open Folder ${idx}",
-font => "Courier 20 bold")->pack(-side => 'bottom', -fill => 'both',
-expand => 1);
$idx++;
}
MainLoop;
}
sub main {
my ($self) = @_;
$self->_build_mw;
}
__PACKAGE__->meta->make_immutable;
}
my $app = Application->new->main unless caller;
1;
__YAML__
- header: Command 1
cta: Process 1
options:
- Option 1
- Option 2
- Option 3
- Option 4
- Option 5
- header: Command 2
cta: Process 2
options:
- Option 1
- Option 2
- Option 3
- Option 4
- Option 5
- header: Command 3
cta: Process 3
options:
- Option 1
- Option 2
- Option 3 - Option 4
- Option 5
- header: Command 4
cta: Process 4
options:
- Option 1
- Option 2
- Option 3
- Option 4
- Option 5
- header: Command 5
cta: Process 5
options:
- Option 1
- Option 2
- Option 3
- Option 4
- Option 5
- header: Command 6
cta: Process 6
options:
- Option 1
- Option 2
- Option 3
- Option 4
- Option 5
- header: Command 7
cta: Process 7
options:
- Option 1
- Option 2
- Option 3
- Option 4
- Option 5
- header: Command 8
cta: Process 8
options:
- Option 1
- Option 2
- Option 3
- Option 4
- Option 5
- header: Command 9
cta: Process 9
options:
- Option 1
- Option 2
- Option 3
- Option 4
- Option 5
- header: Command 10
cta: Process 10
options:
- Option 1
- Option 2
- Option 3
- Option 4
- Option 5
- header: Command 11
cta: Process 11
options:
- Option 1
- Option 2
- Option 3
- Option 4
- Option 5
- header: Command 12
cta: Process 12
options:
- Option 1
- Option 2
- Option 3
- Option 4
- Option 5
Also, there is a Gist upon GitHub. The link is :
https://gist.github.com/jmcveigh/cee40862fd4f4b545576cc59184f44b5
Warm regards,
Jason McVeigh
