view release on metacpan or  search on metacpan

WorldCanvas.pm  view on Meta::CPAN

package Tk::WorldCanvas;
require Tk::Canvas;
require Tk::Derived;
use strict;
use Tk;

use vars qw($VERSION);
$VERSION = '1.2.7';

#Version
#1.0.0 -- Sept 20, 2001 -- Initial release.
#1.1.0 -- Oct  29, 2001 -- Added '-changeView' callback option
#1.2.0 -- Jan  29, 2002 -- Added 'getView' method,
#                          better error handleing in 'bbox',
#                          cleaned up syntax
#1.2.1 -- May  17, 2002 -- changed package name to Tk::WorldCanvas
#1.2.2 -- June 28, 2002 -- Fixed bug in 'coords'
#1.2.3 -- July 31, 2002 -- Fixed another bug in 'coords', and an agrument passing bug.
#1.2.4 -- Sept  5, 2002 -- Added to POD
#1.2.5 -- Sept  6, 2002 -- Enhanced view window scaleing on canvas resize
#1.2.6 -- Nov   1, 2002 -- Fixed _view_area_canvas bug.
#1.2.7 -- Nov  19, 2002 -- handle fractional arguments to canvas(x|y)

@Tk::WorldCanvas::ISA = qw(Tk::Derived Tk::Canvas);

Construct Tk::Widget 'WorldCanvas';

sub ClassInit {
    my ($worldcanvas, $mw) = @_;

    $worldcanvas->SUPER::ClassInit($mw);
}

sub InitObject {
    my ($worldcanvas, $args) = @_;

    my $pData = $worldcanvas->privateData;
    $pData->{'bbox'} = [0, 0, -1, -1];
    $pData->{'scale'} = 1;
    $pData->{'movex'} = 0;
    $pData->{'movey'} = 0;
    $pData->{'bboxvalid'} = 1;
    $pData->{'width'} = $worldcanvas->width;
    $pData->{'height'} = $worldcanvas->height;

    $worldcanvas->configure(-confine => 0);

    $worldcanvas->ConfigSpecs('-bandColor' => ['PASSIVE', 'bandColor', 'BandColor', 'red'],
                              '-bandcolor' => '-bandColor',
                              '-changeView' => ['CALLBACK', 'changeView', 'ChangeView', undef],
                              '-changeview'  => '-changeView');

    $worldcanvas->CanvasBind('<Configure>' =>
        sub {
            my $w = $worldcanvas->width;
            my $h = $worldcanvas->height;
            my $ow = $pData->{'width'};
            my $oh = $pData->{'height'};
            if ($w != $ow or $h != $oh) {
                my $b = $worldcanvas->cget('-borderwidth');
                _view_area_canvas($worldcanvas, $b, $b, $ow - $b, $oh - $b);
                $pData->{'width'} = $w;
                $pData->{'height'} = $h;

                my $bbox = $pData->{'bbox'};
                my $le = $worldcanvas->canvasx($b);
                my $re = $worldcanvas->canvasx($w - $b);
                my $te = $worldcanvas->canvasy($b);
                my $be = $worldcanvas->canvasy($h - $b);
                if (_inside(@$bbox, $le, $te, $re, $be)) {
                    $worldcanvas->viewAll;
                }
            }
        }
    );

    $worldcanvas->SUPER::InitObject($args);
}

sub getView {
    my ($canvas) = @_;

    my $borderwidth = $canvas->cget('-borderwidth');
    my $right_edge = $canvas->width - $borderwidth;