Anyways, this will take a photo as ARGV[0] on the commandline, or will retreive an image from the net (if no image is given).
#!/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 $ph = 400;
my $c = $mw->Scrolled('Canvas',
-width=>400,
-height=>$ph,
-bg=>'white',
-scrollregion=>[0,0,1000,1000],
-scrollbars=>'sw')->pack(-expand=>1, -fill=>'both');
my $bimage = $c->createImage( 0,0,
-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,
);
my $real_can = $c->Subwidget('scrolled');
$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);
}
perlmonks.org content © perlmonks.org and aukjan, zentara
prlmnks.org © 2006 edmund von der burg (eccles & toad)
v 0.03