# -*- perl -*-
BEGIN { $|=1; $^W=1; }
use strict;
use FindBin;
use lib $FindBin::RealBin;
BEGIN {
if (!eval q{
use Test::More;
1;
}) {
print "1..0 # skip: no Test::More module\n";
exit;
}
}
use TkTest qw(catch_grabs);
plan tests => 22;
use_ok("Tk");
use_ok("Tk::BrowseEntry");
my $mw;
eval {$mw = Tk::MainWindow->new();};
eval { $mw->geometry('+10+10'); };
is($@, "", "can create MainWindow");
ok(Tk::Exists($mw), "MainWindow creation");
my(@listcmd, @browsecmd);
my $listcmd = sub { @listcmd = @_ };
my $browsecmd = sub { @browsecmd = @_ };
my( $bla, $be );
eval { $be = $mw->BrowseEntry(-listcmd => $listcmd,
-browsecmd => $browsecmd,
-textvariable => \$bla,
)->pack; };
is("$@", "", "can create BrowseEntry");
ok(Tk::Exists($be), "BrowseEntry creation");
$be->insert('end', 1, 2, 3);
is($be->get(0), 1, "correct element in listbox");
$be->idletasks;
# this can "fail" if KDE screen save is up, or user is doing something
# else - such snags are what we should expect when calling binding
# methods directly ...
catch_grabs { $be->BtnDown } 0;
ok(@listcmd, "-listcmd");
ok($listcmd[0]->isa('Tk::BrowseEntry'), "1st argument in -listcmd");
my $listbox = $be->Subwidget('slistbox')->Subwidget('listbox');
ok($listbox->isa('Tk::Listbox'), "listbox subwidget");
$listbox->selectionSet(0);
$listbox->idletasks;
my($x, $y) = $listbox->bbox($listbox->curselection);
$be->LbChoose($x, $y);
is(@browsecmd, 2, "-browsecmd");
ok($browsecmd[0]->isa('Tk::BrowseEntry'),
"1st argument in -browsecmd");
is($browsecmd[1], 1, "2nd argument in -browsecmd");
my $be2;
eval { $be2 = $mw->BrowseEntry(-choices => [qw/a b c d e/],
-textvariable => \$bla,
-state => "normal",
)->pack; };
is("$@", "", "create BrowseEntry");
ok(Tk::Exists($be2), "BrowseEntry creation");
catch_grabs {
# Testcase:
# From: "Puetz Kevin A" <PuetzKevinA AT JohnDeere.com>
# Message-ID: <0B4BDC724143544EB509F90F7791EB64026EF8E1@edxmb16.jdnet.deere.com>
my $var = 'val2';
my $browse = $mw->BrowseEntry
(-label => 'test',
-listcmd => sub { $_[0]->choices([undef, 'val1','val2']) },
-variable => \$var,
)->pack;
is($var, 'val2');
$browse->update;
$browse->BtnDown;
$browse->update;
is($var, 'val2');
$browse->destroy;
} 2;
{
# http://perlmonks.org/?node_id=590170
my $active_text_color = "#000000";
my $bgcolor = "#FFFFFF";
my $text_font = 'helvetica 12';
my $browse = $mw->BrowseEntry(-label=>'Try Me:',
-labelPack=>[qw(-side left -anchor w)],
-labelFont=>$text_font,
-labelForeground=>$active_text_color,
-labelBackground=>$bgcolor,
-width=>5,
-choices=>[qw(A B C)],
)->pack(-side=>'left', -expand=>1, -fill=>'x');
my @children = $browse->children;
is(scalar(@children), 3, "Auto-creation of Frame label");
is((scalar grep { $_->isa("Tk::LabEntry") } @children), 1, "Has one LabEntry");
is((scalar grep { $_->isa("Tk::Button") } @children), 1, "Has one Button");
is((scalar grep { $_->isa("Tk::Toplevel") } @children), 1, "Has one Toplevel");
is((scalar grep { $_->isa("Tk::Label") } @children), 0, "Has no Label");
}
#&Tk::MainLoop;
1;
__END__