# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl t/Tk-VisualBrowser.t'
#########################
# change 'tests => 1' to 'tests => last_test_to_print';
use Test::More tests => 14;
BEGIN { use_ok('Tk::VisualBrowser') };
#########################
# Insert your test code below, the Test::More module is use()ed here so read
# its man page ( perldoc Test::More ) for help writing this test script.
use Tk;
my $top = MainWindow->new;
my $vb;
my $VERSION = 1.00;
# Menubar
$top->configure(-menu => my $menubar = $top->Menu
, -title => "Tk::VisualBrowser ".$Tk::VisualBrowser::VERSION
);
$menubar->cascade(-label => "~File",
-menuitems =>
[
[command => 'List of Pictures', '-command', sub{ show_list( $vb) }],
[command => 'List of selected', '-command', sub{ show_selected( $vb) }],
[command => 'Swap', '-command', sub{ $vb->swap_selected }],
[command => 'Select all', '-command', sub{ $vb->select_all }],
[command => 'Deselect all', '-command', sub{ $vb->deselect_all }],
[qw/command Exit -command/, sub{ exit }],
],
);
$menubar->cascade(-label => "~Help",
-menuitems =>
[
[qw/command About -command/, sub{ print "test.pl: version $VERSION\n"}],
[qw/command Contents -command/, sub{ print "TODO: implement Help ...\n" }],
],
);
$vb = $top->VisualBrowser(-rows => 3, -cols => 4)->pack;
my @IMG = qw(
ScanImage16.gif
ScanImage17.gif
ScanImage18.gif
ScanImage19.gif
ScanImage20.gif
ScanImage21.gif
ScanImage22.gif
ScanImage23.gif
ScanImage39.gif
ScanImage40.gif
ScanImage41.gif
);
my @IMG2 = @IMG; # copy
# try to use 0 as number of rows:
eval {
$vb->configure(-rows => 0, -cols => 4);
};
#print ">>$@<<\n";
ok($@, "error in number of rows");
# try to use 0 as number of cols:
eval {
$vb->configure(-rows => 3, -cols => 0);
};
#print ">>$@<<\n";
ok($@, "error in number of cols");
$vb->configure(-pictures => \@IMG,
-rows => 3, -cols => 3,
-thumbnail => \&get_thb,
-highlight => "yellow",
);
my $b_exit = $top->Button(
-text => "Exit",
-width => 6,
-command => sub{
exit;
},
)->pack();
$vb->scroll(0);
# select all
$vb->select_all;
my @sel = $vb->get_selected;
ok( eq_array(\@sel, \@IMG), "select all");
# select none
$vb->deselect_all;
@sel = $vb->get_selected;
is( scalar @sel, 0, "deselect all");
$vb->select(3);
$vb->select(4);
@sel = $vb->get_selected_idx;
ok( eq_array(\@sel, [3, 4]), "select 3, 4");
@sel = $vb->get_selected;
ok( eq_array(\@sel, [$IMG[3], $IMG[4]]), "select names 3, 4");
$vb->deselect_all;
# swap two pictures
($IMG2[3], $IMG2[5]) = ($IMG2[5], $IMG2[3]);
$vb->{SEL}[5] = 1; # whitebox test ...
$vb->{SEL}[3] = 1;
$vb->swap_selected;
$vb->select_all;
@sel = $vb->get_selected;
$vb->deselect_all;
ok( eq_array(\@sel, \@IMG2), "swap");
# select more than two and try to swap
$vb->{SEL}[5] = 1; # whitebox test ...
$vb->{SEL}[3] = 1;
$vb->{SEL}[2] = 1;
my $ok = $vb->swap_selected;
is($ok, 0, "error in swap");
$vb->deselect_all;
# try to get color info about some subwidgets:
my $bg = $vb->{Thmb}[0][1]->cget(-background);
is($bg, "#CCCCCC", "bg Thmb");
$vb->configure(-bg_color => "#c3c3c3");
$vb->configure(-pictures => \@IMG ); # in order to get the new colors via rebuild ...
$bg = $vb->{Thmb}[0][1]->cget(-background);
is($bg, "#c3c3c3", "bg Thmb");
#======================
if (! $ENV{INTERACTIVE_MODE}){
$top->after(1500, sub{ remove_test();} );
$top->after(3000, sub{ ok(1, "exit automatically"); exit} );
}
MainLoop;
sub get_thb {
shift;
}
sub show_list { #{{{
my $vb = shift;
show_files(@{$vb->cget('-pictures')});
} # show_list }}}
sub show_selected { #{{{
my $vb = shift;
show_files($vb->get_selected);
} # show_selected #}}}
sub show_files { #{{{
my @files = @_;
my $tl = $top->Toplevel( -title => "Pictures in ./");
my $list = $tl -> ScrlListbox(
-label => 'Pictures',
-height => 15,
-width => 55,
-selectmode => 'single',
-exportselection => 0,
) -> pack;
my $b_ok = $tl->Button(
-text => "Ok",
-width => 4,
-command => sub{
$tl->destroy;
},
)->pack;
foreach my $jpg ( @files ){
$list->insert("end", " $jpg");
}
} # show_files }}}
sub remove_test { # {{{
$vb->deselect_all();
$vb->select(3);
$vb->select(5);
$vb->remove_selected();
$vb->select_all();
my @sel = $vb->get_selected;
print "@sel\n";
print "@IMG\n";
splice(@IMG2, 5, 1);
splice(@IMG2, 3, 1);
ok( eq_array(\@sel, \@IMG), "select after remove");
ok( eq_array(\@sel, \@IMG2), "select after remove");
} # remove_test }}}
__END__
vim:ft=perl:foldmethod=marker:foldcolumn=4