use Tk; use Tk; use Tk::PNG; use Tk::LabFrame; use Tk::Radiobutton; use Tk::Pane; use Tk::WorldCanvas; use strict; our $currdwg = "./largeimage.png"; our $ZC; our $sr; our ($imgX, $imgY); our $MW = MainWindow->new(-title => " PROXY FOR MW"); $MW->geometry("+4+5"); review($MW); MainLoop; sub review { my ($MW) = @_; my ($RW, $CW) = makeReviewScreen($MW); } sub makeReviewScreen { my ($MW) = @_; our $width = $MW->screenwidth - 145; my $RW = $MW->Toplevel(-title => 'XXX'); $RW->geometry("+0+5"); my $LW = $RW->Frame; my $CW = $RW->Scrolled('WorldCanvas', -width => $width, -height => '480', -background => 'white', -borderwidth => '3', -scrollbars => 'se', -relief => 'sunken', -scrollregion => [-100,0, 6000,4000]); $ZC = new ZoomCanvas($CW, 1); $LW->pack(-side => 'left', -fill => 'y', -expand => '1', -anchor => 'nw', ); $CW->pack(-side => 'left', -fill => 'both', -expand => '1' ); $RW->bind('' => sub { print "start\n"; start_problems($MW, $ZC); print "end\n"; } ); print "init start\n"; start_problems($MW, $ZC); print "init end\n"; return ( $RW, $CW); } sub start_problems { my ($MW, $ZC) = @_; my @items = $ZC->find('all'); for my $item (@items) { $ZC->delete($item); } show_drawing($MW, $ZC); } sub show_drawing { use GD::Image; use MIME::Base64 qw[ encode_base64 ]; my ($MW, $ZC) = @_; #----------------- Display drawing at specified +- zoom ------------------# my $orig = GD::Image->new($currdwg); my ($xMax, $yMax) = $orig->getBounds; $sr = 3500/ $xMax; ($imgX, $imgY) = map { int($_ * $sr) } $orig->getBounds; my $small = GD::Image->new($imgX, $imgY); $small->copyResampled($orig, 0, 0, 0, 0, $imgX, $imgY, $orig->getBounds); my $img = $MW->Photo(-data => encode_base64( $small->png ), -format => 'png' ); $MW->configure( -title => " REVIEW INTERLOCKING DRAWING - $currdwg ($xMax x $yMax)"); my $dwg = $ZC->createImage($MW,0,0, -anchor => 'nw', -image => $img, -tags => 'dwg'); $ZC->centerTags($dwg); undef $img; undef $small; undef $orig; return ([$xMax, $yMax],[$imgX, $imgY]); } package ZoomCanvas; use strict; use Tk; use feature 'state'; sub new { my $class = shift; my $canvas = shift; my $zoom = shift; # Quick loose check to ensure $canvas is a WorldCanvas my $test1 = (ref($canvas) eq "Tk::Frame"); use Data::Dumper; my $test2 = (Dumper($canvas) =~ "worldcanvas"); if (! ($test1 && $test2)) { die "ZoomCanvas::new: canvas argument not WorldCanvas!\n" } if (! defined $zoom) { $zoom =1; } my $self = { CANVAS => $canvas, ZOOM => $zoom }; bless $self, $class; return $self; } sub AUTOLOAD { my @args = @_; my $self = shift @args; my $substring = $ZoomCanvas::AUTOLOAD; my @splitSub = split("::", $substring); my $sub = $splitSub[1]; my $canvas = $self->{CANVAS}; return $canvas->$sub(@args); } sub createImage { use Tk::Photo; use Storable; use Storable qw(nstore dclone); # Create state vars state $xoff; state $yoff; state %miscArgs; state $MW; my @args = @_; my $self = shift @args; my $canvas = $self->{CANVAS}; my $MW_tmp = shift @args; # Original args my $xoff_tmp = shift @args; my $yoff_tmp = shift @args; my %miscArgs_tmp = @args; if ( defined $MW_tmp && defined $xoff_tmp && defined $yoff_tmp && (keys %miscArgs_tmp) ) { $MW = $MW_tmp; $xoff = $xoff_tmp; $yoff = $yoff_tmp; if (exists $miscArgs{-image}) { delete $miscArgs{-image}; } %miscArgs = %miscArgs_tmp; } my $img = $miscArgs{-image}; my $zimg = $MW->Photo(); ($self->{ZOOM} > 1) ? $zimg->copy($img, -zoom => $self->{ZOOM}) : $zimg->copy($img, -subsample => (1 / $self->{ZOOM})); $miscArgs{-image} = $zimg; my @miscArgs_list = %miscArgs; my $return = $canvas->createImage($xoff,$yoff, @miscArgs_list); $miscArgs{-image} = $img; delete $miscArgs{-image}; delete $miscArgs_tmp{-image}; undef $img; undef $zimg; return $return; } 1;