Re: Simple ok/cancel routine
[email protected] (Jason McVeigh) Tue, 14 Jun 2016 20:42:30 -0400
| Newsgroups | perl.tcltk |
|---|---|
| Message-ID | <[email protected]> |
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 <[email protected]
>>> <mailto:[email protected]>> 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