#!/usr/bin/perl
use warnings;
use strict;
use Tk;

my $w=20;
my $x=0;
my $y=0;

# make up some data
my %bars;
foreach (0..500){
   my $name = random_string();
   $bars{$name}{'name'} = $name; 
   $bars{$name}{'data'} = 100 +rand 1200; 
}

my $mw=tkinit;
my $c = $mw->Scrolled('Canvas',
        -bg=>'white')->pack(-expand=>1,-fill=>'both');


#---determine font spacing by making a capital W---
 my $fonttest =  $c->createText(0,0,
              -fill    => 'black',
              -text    => 'W',            
              );
my ($bx,$by,$bx1,$by1) = $c->bbox($fonttest);
my $width  = $bx1 - $bx;
my $height = $by1 - $by;
$c->delete($fonttest);
#--------------------------------------------

foreach my $key(sort keys %bars) {
  my ( $bg, $fg ) = random_colors();
  
  $bars{$key} = $c->createRectangle($x,$y,$x+20,$bars{$key}{'data'},
             -fill=> $bg,
             -tags=>[ $key]
          );

  my(@text) = split /(.)/, $key;
  #print "@text\n"; 
 foreach my $t( @text ){
   $c->createText($x+10,$y,
           -anchor=>'n',
       -fill => $fg,
       -text => $t
          );
     $y += $height/2;      
    }

      $y = 0;
      $x+=20;
}


$mw->Button(
    -text    => "Save",
    -command => [sub {
         $c->update;
         my @capture=();
         my ($x0,$y0,$x1,$y1)=$c->bbox('all');
         @capture=('-x'=>$x0,'-y'=>$y0,-height=>$y1-$y0,-width=>$x1-$x
+0);
         $c -> postscript(-colormode=>'color',
                               -file=>$0.'.ps',
                   -rotate=>90,
                   -width=>800,
                   -height=>500,    
                   @capture);
                               
                  } 
   
  ]  )->pack;
 
$c->Subwidget('scrolled')->Tk::bind("<Button-1>", [ \&print_xy, Ev('x'
+), Ev('y') ]);
 
# adjust canvas scrollbars size to show all
my ($x0,$y0,$x1,$y1)=$c->bbox('all');
$c->configure( -scrollregion=>[0,0,(($x1-$x0)+20),(($y1-$y0)+20) ] );
 
MainLoop;
##########################################################

sub print_xy {
  #print "@_\n";
  my ($canv, $x, $y) = @_;
  #print "(x,y) = ", $canv->canvasx($x), ", ", $canv->canvasy($y), "\t
+";
  my ($x1,$y1) = ($canv->canvasx($x),$canv->canvasy($y));
 
  my $current = $canv->find(qw/withtag current/);
  my (@tags) = $canv->gettags($current);
  print "$y1 for @tags\n\n";
}


sub random_colors {
    my ( $r, $g, $b ) = map { int rand 256 } 1 .. 3;

    my $lum = ( $r * 0.3 ) + ( $g * 0.59 ) + ( $b * 0.11 );

    my $bg = sprintf( "#%02x%02x%02x", $r, $g, $b );
    my $fg = $lum < 128 ? "white" : "black";
    return ( $bg, $fg );
}

sub random_string {
  my($string) = '';
  my($length) = 6;
  my(@chars) = ('A' .. 'Z', 'a' .. 'z', 0 .. 9);
   while (length($string) != $length) {
    $string .= $chars[ rand($#chars) ];
   }
  return($string);
}
[download]