#!/usr/bin/perl
use warnings;
use strict;
use Tk;
use Tk::JPEG;
use Tk::PNG;

my $file = shift || die "need a bmp, gif,jpg or png as arg 1\n";

my $mw  = Tk::MainWindow->new;

my $topframe = $mw->Frame(-bg => 'black')->pack(-fill=>'x');
my $tf1 = $topframe->Frame(-bg => 'black')->pack(-side=>'left',-fill=>
+'x');

my $xy = $tf1->Label(-text => '  X - Y  ',
                       -fg => 'hotpink',
               -bg => 'black',
                  )->pack(-side => 'top',-padx=>2);

my $rgb = $tf1->Label(-text => 'R - G - B',
                       -fg => 'hotpink',
               -bg => 'black',
                  )->pack(-side => 'top', -padx=>2);

my $hex = $tf1->Label(-text => '   HEX   ',
                       -fg => 'hotpink',
               -bg => 'black',
                  )->pack(-side => 'top',-padx=>2);

my $tf2 = $topframe->Frame(-bg => 'black')->pack(-side=>'left',-fill=>
+'x');

my $xycurrent;
my $xyr = $tf2->Label(-textvariable => \$xycurrent,
                       -fg => 'lightgreen',
               -bg => 'black',
                  )->pack(-side => 'top',-padx=>2);
my $rgbcurrent;
my $rgbr = $tf2->Label(-textvariable => \$rgbcurrent,
                       -fg => 'lightgreen',
               -bg => 'black',
                  )->pack(-side => 'top', -padx=>2);

my $hexcurrent;
my $hexr = $tf2->Label(-textvariable => \$hexcurrent,
                       -fg => 'lightgreen',
               -bg => 'black',
                  )->pack(-side => 'top',-padx=>2);

my $swatch = $topframe->Label(
                     -text => '       ',
                     -bg=>'black',
                    )->pack(-side=>'left',-fill=>'y',-pady => 5); 

my $tf3 = $mw->Frame(-bg => 'hotpink')->pack(-fill=>'x');
my $divider = $tf3->Label(
                     -text => '       ',
                     -bg=>'hotpink',
                    )->pack(-side=>'left',-fill=>'y',-pady => 1); 


my $can = $mw->Scrolled('Canvas',
                 -height => 400,
         -width  => 400,
         -scrollbars => 'osoe',
                 -highlightthickness=>0,
         -borderwidth =>0,
                 )->pack( -fill =>'both',-expand=>1);

my $realcan = $can->Subwidget('scrolled');

my $img = $mw->Photo( -file => "$file", 
              -palette => '256/256/256' );

$can->createImage(0,0,  #hardcoded offset
                  -image => $img, 
          -anchor => 'nw',
          -tags => ['img'],
           );

my @bbox = $can->bbox( 'img'  );

$can->configure(-scrollregion => [@bbox] );

$realcan->Tk::bind("<Motion>", [ \&print_xy, Ev('x'), Ev('y') ]);

$realcan->Tk::bind("<Leave>", sub{
            $xycurrent  = '';
            $rgbcurrent = '';
        $hexcurrent = '';
       });


MainLoop();
###########################################################
# a cheap hack to prevent the Tk Photo object from issuing
# an out of bounds error if the window is expanded bigger 
# than the photo
sub Tk::Error { }
#####################################################
sub print_xy {
  my ($canv, $x, $y) = @_;
  $xycurrent = $canv->canvasx($x).' - '.$canv->canvasy($y);    
 
   my($r,$g,$b) = $img->get($canv->canvasx($x), $canv->canvasy($y) );

   $rgbcurrent = sprintf('%.3d', $r).'-'.sprintf('%.3d', $g).'-'.sprin
+tf('%.3d', $b); 

  #convert to hex from decimal
   $r = sprintf('%.2x', $r);
   $g = sprintf('%.2x', $g);
   $b = sprintf('%.2x', $b);
   $hexcurrent = $r.'-'.$g.'-'.$b; 

$swatch->configure(-bg=>"#$r$g$b");

}
[download]