view release on metacpan or  search on metacpan

t/tileTree.t  view on Meta::CPAN

# Demo of tile widget

use warnings;
use strict;

use Tcl::pTk;

use Test::More;
use Test::Deep;


my $TOP = MainWindow->new;

# This will skip if Tile widgets not available
unless ($Tcl::pTk::_Tile_available) {
    $TOP->destroy;
    plan skip_all => 'Tile unavailable';
}

plan tests => 8;

my $msg = $TOP->ttkLabel( -text => 
        "Ttk is the new Tk themed widget set. One of the widgets it includes is a tree widget, which can be configured to display multiple columns of informational data without displaying the tree itself. This is a simple way to build a listbox that ...
        qw/ -wraplength 4i -justify left/)->pack(-side => 'top', -fill => 'x');
 
        
# Make the button frame
my $bigFrame = $TOP->ttkFrame()->pack(-expand => 'y', -fill => 'both');

my $tree = $bigFrame->Scrolled('ttkTreeview',-columns => [qw/ country capital currency/], -show => 'headings',       -scrollbars => 'se' )->pack(-fill => 'both', -expand => 1);
#my $tree = $bigFrame->ttkTreeview(-columns => [qw/ country capital currency/], -show => 'headings')->pack(-fill => 'both', -expand => 1);

my @data = (        
    'Argentina',	'Buenos Aires',		'ARS',
    'Australia',	'Canberra',		'AUD',
    'Brazil',		'Brazilia',		'BRL',
    'Canada',		'Ottawa',		'CAD',
    'China',		'Beijing',		'CNY',
    'France',		'Paris',		'EUR',
    'Germany',		'Berlin',		'EUR',
    'India',		'New Delhi',		'INR',
    'Italy',		'Rome',			'EUR',
    'Japan',		'Tokyo',		'JPY',
    'Mexico',		'Mexico City',		'MXN',
    'Russia',		'Moscow',		'RUB',
    'South Africa',	'Pretoria',		'ZAR',
    'United Kingdom',	'London',		'GBP',
    'United States',	'Washington, D.C.',	'USD',
    );


my $style = $tree->cget(-style);
my $font = $tree->ttkStyleLookup( $style, -font);

## Code to insert the data nicely
foreach my $col (qw/ country capital currency /){
        my $name = ucfirst($col);
        # Set heading name and sort fommand, using the real (not scrolled) tree widget
        $tree->heading($col, -command => [\&SortBy, $tree->Subwidget('scrolled'), $col, 0], -text => $name );
        
        my $len = $tree->fontMeasure($font, $name);
        #print "Setting $col width to $len\n";
        $tree->column($col, -width, $len+10);
}

my @IDs;
while(@data){
        my $country  = shift @data;
        my $capital  = shift @data;
        my $currency = shift @data;
        
        push @IDs, $tree->insert('', 'end', -values => [$country, $capital, $currency]);
        
        # Auto-set length of field based on data init
        my %rowLookup; # Hash for quick lookup
        @rowLookup{qw/ country capital currency /} = ($country, $capital, $currency);
        foreach my $col (qw/ country capital currency /){
             
                my $len = $tree->fontMeasure($font, $rowLookup{$col}."  ");
                if( $tree->column($col, -width) < $len ){
                        #print "setting $col width to $len\n";
                        $tree->column($col, -width => $len);
                }
        }
                     
}

# New tests added in response to
# https://github.com/chrstphrchvz/perl-tcl-ptk/issues/7

is(scalar(@IDs), 15, 'Obtain IDs for each inserted item');