#!/usr/bin/perl -w
 
use Tk;
use strict;
use warnings;
 
# Globals
 
my $scroll_x = 0;
my $scroll_y = 0;
 
my $b_button_1_down = 0;    # Is the left mouse button currently down?
my ($x0, $y0, $x1, $y1);    # Starting and ending (x,y) coordinates
my $rect_id = 0;            # Last rectangle drawn
 
# Main program / GUI setup
my $mw = MainWindow->new;
my $c = $mw->Scrolled('Canvas',
    -width        => 200,
    -height       => 200,
    -background   =>'blue',
    -scrollregion => [ 0, 0, 1500, 1000 ]
);
 
$c->pack(-expand => 1, -fill => 'both');
bind_left_mouse($c);
 
MainLoop;

 
# Subroutines
 
sub bind_left_mouse
{
    my ($c) = @_;
 
    # Create "callback"; subroutines which get called whenever the
    # corresponding event is triggered.  Note that Ev('x') and Ev('y')
    # will tell us, at the time they're used, what the current (x,y)
    # coordinate pair was.  Note, too, that we're now getting the actual
    # Canvas object $cv from the Scrolled object $c, using the Subwidget()
    # method, and using it for the binding, and as a parameter to each of
    # the 3 callbacks.
    #
    my $cv = $c->Subwidget("canvas");
    my $cb1 = [ \&left_mouse_down,    $cv, Ev('x'), Ev('y')];
    my $cb2 = [ \&left_mouse_release, $cv, Ev('x'), Ev('y')];
    my $cb3 = [ \&left_mouse_moving,  $cv, Ev('x'), Ev('y')];
 
    # Bind the callbacks
    $cv->CanvasBind("<ButtonPress-1>",   $cb1);
    $cv->CanvasBind("<ButtonRelease-1>", $cb2);
    $cv->CanvasBind("<Motion>",          $cb3);
}
 
sub left_mouse_down
{
    # This gets called whenever the left-mouse button is clicked
    my ($ev, $cv, $x, $y) = @_;
 
    # Figure out what adjustments have to be made for the scroll location
    $x = $cv->canvasx($x);
    $y = $cv->canvasy($y);

    $b_button_1_down = 1;
    ($x0, $y0) = ($x, $y);
    print "(debug) button1 down, (x,y) => ($x,$y)\n";
}
 
sub left_mouse_moving
{
    # This gets called whenever the mouse moves.  It's true for ALL
    # mouse motion, but we're really just interested in when the mouse
    # is moving -and- the left mouse button is held down; hence the name.
    #
    my ($ev, $cv, $x, $y) = @_;
    return unless $b_button_1_down;

    # Figure out what adjustments have to be made for the scroll location
    $x = $cv->canvasx($x);
    $y = $cv->canvasy($y);

    print "(debug) button1 moving, (x,y) => ($x,$y)\n";
    $rect_id and $cv->delete($rect_id); # Delete any old rectangle first
    my @opts = (-outline => 'yellow', -dash => '.  ');
    $rect_id = $cv->createRectangle($x0, $y0, $x, $y, @opts);
}
 
sub left_mouse_release
{
    # This gets called whenever the left-mouse button is released
    my ($ev, $cv, $x, $y) = @_;
    $b_button_1_down = 0;

    # Figure out what adjustments have to be made for the scroll location
    $x = $cv->canvasx($x);
    $y = $cv->canvasy($y);

    ($x1, $y1) = ($x, $y);
    print "(debug) button1 release, (x,y) => ($x,$y)\n";
    # Now do something with the triangle at (x0,y0,x1,y1)...
    $rect_id and $c->delete($rect_id); # Delete any old rectangle first
    my @opts = (-fill => 'purple');
    $rect_id = $c->createRectangle($x0, $y0, $x, $y, @opts);
}