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

my $mw=tkinit;

my $imagin = shift;
$imagin ||= '';
my $image;

if(length $imagin){
   $image  = $mw->Photo(-file =>$imagin);
}else{
   $image = &get_photo;
}

my $c = $mw->Scrolled('Canvas',
     -width=>400,
     -height=>400,
     -bg=>'white',
     -scrollregion=>[0,0,1000,1000],
     -scrollbars=>'sw')->pack(-expand=>1, -fill=>'both');

my $real_can = $c->Subwidget('scrolled');
my $real_can_h = $real_can->reqheight; 

my $sc_h = $c->cget('-height'); 
my $pad =  ($real_can_h - $sc_h)/2;
#  pad prevents a startup jitter due to border width

my $bimage = $c->createImage( 0,$pad,   
         -anchor => 'nw',               
         -image  => $image,   
    );

for(0..500){
 if( $_ % 2 == 0){
      $c->createRectangle(0,  5 + $_ * 10, 30,  15 + $_ *10,
              -fill =>'hotpink',
            );
      
      $c->createText( 3, 5 + $_ * 10,
              -fill =>'white',
              -text => $_,
          -anchor =>'nw',
        );
  
      next;
     }
 }

my $ybar = $c->Subwidget("yscrollbar");
$ybar->configure(
           -background => "lightgreen", 
           -activebackground => "green",
       -troughcolor => "black",
           -command => \&yscrollcallback,
        );


$mw->Button(-text =>'Change Scroll Region',
            -command =>sub{
        $c->configure(-scrollregion =>[0,0,2000,2000]);
        })->pack();

MainLoop;
######################################################################
#if you specify a yscrollcallback, you will override the
#normal scroll behavior.

sub yscrollcallback{
    #restore original function
    $c->yview(@_);
 
   my($z,$z1) = $c->yview;

   my(undef,undef,undef,$sry) = $c->cget('scrollregion');

   my $real_can_h = $real_can->reqheight; 
#   print "$sry  $real_can_h\n";
   my $div = $sry/$real_can_h;  
#   print "div $div\n";

$c->coords($bimage, 0,  $div *$z * $real_can_h  );
$c->update;
   
}

######################################################################
+####3
sub get_photo{

 use LWP::Simple;
 use MIME::Base64;

 my $URL = 'http://zentara.net/2uni2.jpg';
 
 my $content = encode_base64(get($URL));
  
return $mw->Photo(-data => $content);

}
[download]