#!/usr/bin/perl
use warnings;
use strict;
use Tk;
use Tk::Table;
use Tk::Entry;
my $mw    = new MainWindow;
my $title = $mw->title( "kapsule" );

my $show_table_frame =
 $mw->Frame()
 ->pack( -side => "top", -fill => "both", -anchor => "nw", -padx => "10" );

my $button = $mw->Button(
   -text    => "show",
   #-font    => "verdanafont 10 bold",
   -command => sub {

      if ( $show_table_frame->ismapped ) {
         $show_table_frame->packForget();
      }
      else {
         $show_table_frame->pack();
      }
   }
)->pack();


my $show_table = $show_table_frame->Table(
   -columns      => 3,
   -rows         => 5,
   -scrollbars   => "o",
   -fixedrows    => 1,
   -fixedcolumns => 0,
   -relief       => 'raised',
   -takefocus    => "0",
   -pady         => "5"
);


my %chs; # column headers

foreach my $col(1..3){

    $chs{$col}{'button'} = $show_table->Button( -text => "Col $col ", 
              -width => 15, 
              -relief => 'ridge',
              -bg=>'white',
              -command => sub{ 
                  print "Col $col selected\n";    
    
                        for my $row(1..4){
                           print  $chs{$col}{$row}{'ent'}->get,"\n";  
                           $chs{$col}{$row}{'ent'}->configure(-bg=>'lightyellow');                     
                     }
              } );
   $show_table->put(0, $col , $chs{$col}{'button'} );
}


for ( my $col = 1 ; $col < 4 ; $col++ ) {
   for ( my $row = 1 ; $row < 5 ; $row++ ) {
      $chs{$col}{$row}{'ent'} =
       $show_table->Entry( -font => "verdana 10" )->pack( -ipady => "15" );
      $chs{$col}{$row}{'ent'}->insert(0, int rand 100);
      $show_table->put( $row, $col, $chs{$col}{$row}{'ent'} );
   }
}
$show_table->pack();
MainLoop;

##</code><code>##

#!/usr/bin/perl
use strict;
use warnings;
use Tk;
use Tk::TableMatrix;
use Tk::TableMatrix::Spreadsheet;

my $top = MainWindow->new;

my $arrayVar = {};

print "Filling Array...\n";
my ($rows,$cols) = (40000, 10);

foreach my $row  (0..($rows-1)){
           $arrayVar->{"$row,0"} = "$row";
    }

foreach my $col  (0..($cols-1)){
           $arrayVar->{"0,$col"} = "$col";
    }

print "Creating Table...\n";
sub colSub{
    my $col = shift;
    return "OddCol" if( $col > 0 && $col%2) ;
}

my $label = $top->Label(-text => "TableMatrix v2 Example")
            ->pack( -expand => 1, -fill => 'both');

my $t = $top->Scrolled('Spreadsheet', 
		-rows => $rows, 
		-cols => $cols,
                -width => 6, 
		-height => 12,
		-titlerows => 1, 
		-titlecols => 1,
		-variable => $arrayVar,
		-coltagcommand => \&colSub,
		-colstretchmode => 'last',
		-flashmode => 1,
		-flashtime => 2,
		-wrap=>1,
		-rowstretchmode => 'last',
		-selectmode => 'extended',
		-selecttype=>'cell',
		-selecttitles => 0,
		-drawmode => 'slow',
		-scrollbars=>'se',
		-sparsearray=>0
                )->pack(-expand => 1, -fill => 'both');

#my $realmatrix = $t->Subwidget('scrolled');

$top->Button( -text => "Clear", 
      -command => sub{&clear})->pack(-expand => 1, -fill => 'x');
$top->Button( -text => "Fill", 
      -command => sub{&fill})->pack(-expand => 1, -fill => 'x');
$top->Button( -text => "Exit", 
      -command => sub{$top->destroy})->pack(-expand => 1, -fill => 'x');

$t->colWidth( -2 => 8, -1 => 9, 0=> 12,  4=> 14);

$arrayVar->{"1,1"} = 42;

Tk::MainLoop;
#########################################
sub TMRefresh {
    #Required input TableMatrix object.
    #use to force matrix to update, a code trick
    return if (!$_[0]);
    $_[0]->configure(-padx =>($_[0]->cget(-padx)));

#$realmatrix->update;
#$t->update;
#$top->update;
#$t->see("100,100");  #trick to force update?
#$t->see("end");
#$t->see("1,1");
}   
#######################################
sub clear{
#$t->clearAll('0,0','end');
 foreach my $row(1..$rows){
    foreach my $col(1..$cols){
     $arrayVar->{"$row,$col"} = 0;
   }
 }

&TMRefresh($t);
}
#####################################
sub fill{

 foreach my $row(1..$rows){
    foreach my $col(1..$cols){
     $arrayVar->{"$row,$col"} = 1000;
   }
 }

&TMRefresh($t);
}
#######################################

##</code><code>##

#!/usr/bin/perl -w
use Tk;
use Tk::DragDrop;
use Tk::DropSite;
use Tk::HList;
use strict;
use vars qw($top $f $lb_src $lb_dest $dnd_token $drag_entry);

#works

$top = new MainWindow;

$top->Label( -text => "Drag items from the left HList to the right one" )->pack;
$f      = $top->Frame->pack;

$lb_src = $f->Scrolled(
    'HList',
    -scrollbars => "osoe",
    -selectmode => 'dragdrop'
)->pack( -side => "left" );

$lb_dest = $f->Scrolled(
    'HList',
    -scrollbars => "osoe",
    -selectmode => 'dragdrop'
)->pack( -side => "left" );

my $i = 0;
foreach ( sort keys %ENV ) {
    $lb_src->add( $i++, -text => $_ );
}

# Define the source for drags.
# Drags are started while pressing the left mouse button and moving the
# mouse. Then the StartDrag callback is executed.
$dnd_token = $lb_src->DragDrop(
    -event        => '<B1-Motion>',
    -sitetypes    => ['Local'],
    -startcommand => sub { StartDrag($dnd_token) },
);

# Define the target for drops.
$lb_dest->DropSite(
    -droptypes   => ['Local'],
    -dropcommand => [ \&Drop, $lb_dest, $dnd_token ],
);

MainLoop;

sub StartDrag {
    my ($token) = @_;
    my $w       = $token->parent;    # $w is the source hlist
    my $e       = $w->XEvent;
    $drag_entry = $w->nearest( $e->y );    # get the hlist entry under cursor
    if ( defined $drag_entry ) {

        # Configure the dnd token to show the hlist entry
        $token->configure( -text => $w->entrycget( $drag_entry, '-text' ) );

        # Show the token
        my ( $X, $Y ) = ( $e->X, $e->Y );
        $token->MoveToplevelWindow( $X, $Y );
        $token->raise;
        $token->deiconify;
        $token->FindSite( $X, $Y, $e );
    }
}


# Accept a drop and insert a new item in the destination hlist and delete
# the item from the source hlist
sub Drop {
    my ( $lb, $dnd_source ) = @_;
    $lb->add( $drag_entry, -text => $dnd_source->cget( -text ) );
    $lb_src->delete( "entry", $drag_entry );
    $lb->see($drag_entry);
}